GHC/Handle.hs

   1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
   2
   3 #undef DEBUG_DUMP
   4 #undef DEBUG
   5
   6 -----------------------------------------------------------------------------
   7 -- |
   8 -- Module      :  GHC.Handle
   9 -- Copyright   :  (c) The University of Glasgow, 1994-2001
  10 -- License     :  see libraries/base/LICENSE
  11 --
  12 -- Maintainer  :  libraries@haskell.org
  13 -- Stability   :  internal
  14 -- Portability :  non-portable
  15 --
  16 -- This module defines the basic operations on I\/O \"handles\".
  17 --
  18 -----------------------------------------------------------------------------
  19
  20 module GHC.Handle (
  21   withHandle, withHandle', withHandle_,
  22   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
  23
  24   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  25   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
  26   readRawBuffer, readRawBufferPtr,
  27   writeRawBuffer, writeRawBufferPtr,
  28   unlockFile,
  29
  30   {- ought to be unnecessary, but just in case.. -}
  31   write_off, write_rawBuffer,
  32   read_off,  read_rawBuffer,
  33
  34   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
  35
  36   stdin, stdout, stderr,
  37   IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
  38   hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
  39   hFlush, hDuplicate, hDuplicateTo,
  40
  41   hClose, hClose_help,
  42
  43   HandlePosn(..), hGetPosn, hSetPosn,
  44   SeekMode(..), hSeek, hTell,
  45
  46   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  47   hSetEcho, hGetEcho, hIsTerminalDevice,
  48
  49 #ifdef DEBUG_DUMP
  50   puts,
  51 #endif
  52
  53  ) where
  54
  55 #include "config.h"
  56
  57 import Control.Monad
  58 import Data.Bits
  59 import Data.Maybe
  60 import Foreign
  61 import Foreign.C
  62 import System.IO.Error
  63 import System.Posix.Internals
  64
  65 import GHC.Real
  66
  67 import GHC.Arr
  68 import GHC.Base
  69 import GHC.Read         ( Read )
  70 import GHC.List
  71 import GHC.IOBase
  72 import GHC.Exception
  73 import GHC.Enum
  74 import GHC.Num          ( Integer(..), Num(..) )
  75 import GHC.Show
  76 import GHC.Real         ( toInteger )
  77
  78 import GHC.Conc
  79
  80 -- -----------------------------------------------------------------------------
  81 -- TODO:
  82
  83 -- hWaitForInput blocks (should use a timeout)
  84
  85 -- unbuffered hGetLine is a bit dodgy
  86
  87 -- hSetBuffering: can't change buffering on a stream,
  88 --      when the read buffer is non-empty? (no way to flush the buffer)
  89
  90 -- ---------------------------------------------------------------------------
  91 -- Are files opened by default in text or binary mode, if the user doesn't
  92 -- specify?
  93
  94 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
  95
  96 -- ---------------------------------------------------------------------------
  97 -- Creating a new handle
  98
  99 newFileHandle     :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
 100 newFileHandle finalizer hc = do
 101   m <- newMVar hc
 102   addMVarFinalizer m (finalizer m)
 103   return (FileHandle m)
 104
 105 -- ---------------------------------------------------------------------------
 106 -- Working with Handles
 107
 108 {-
 109 In the concurrent world, handles are locked during use.  This is done
 110 by wrapping an MVar around the handle which acts as a mutex over
 111 operations on the handle.
 112
 113 To avoid races, we use the following bracketing operations.  The idea
 114 is to obtain the lock, do some operation and replace the lock again,
 115 whether the operation succeeded or failed.  We also want to handle the
 116 case where the thread receives an exception while processing the IO
 117 operation: in these cases we also want to relinquish the lock.
 118
 119 There are three versions of @withHandle@: corresponding to the three
 120 possible combinations of:
 121
 122         - the operation may side-effect the handle
 123         - the operation may return a result
 124
 125 If the operation generates an error or an exception is raised, the
 126 original handle is always replaced [ this is the case at the moment,
 127 but we might want to revisit this in the future --SDM ].
 128 -}
 129
 130 {-# INLINE withHandle #-}
 131 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 132 withHandle fun h@(FileHandle m)     act = withHandle' fun h m act
 133 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
 134
 135 withHandle' :: String -> Handle -> MVar Handle__
 136    -> (Handle__ -> IO (Handle__,a)) -> IO a
 137 withHandle' fun h m act =
 138    block $ do
 139    h_ <- takeMVar m
 140    checkBufferInvariants h_
 141    (h',v)  <- catchException (act h_)
 142                 (\ err -> putMVar m h_ >>
 143                           case err of
 144                               IOException ex -> ioError (augmentIOError ex fun h h_)
 145                               _ -> throw err)
 146    checkBufferInvariants h'
 147    putMVar m h'
 148    return v
 149
 150 {-# INLINE withHandle_ #-}
 151 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 152 withHandle_ fun h@(FileHandle m)     act = withHandle_' fun h m act
 153 withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
 154
 155 withHandle_' fun h m act =
 156    block $ do
 157    h_ <- takeMVar m
 158    checkBufferInvariants h_
 159    v  <- catchException (act h_)
 160                 (\ err -> putMVar m h_ >>
 161                           case err of
 162                               IOException ex -> ioError (augmentIOError ex fun h h_)
 163                               _ -> throw err)
 164    checkBufferInvariants h_
 165    putMVar m h_
 166    return v
 167
 168 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
 169 withAllHandles__ fun h@(FileHandle m)     act = withHandle__' fun h m act
 170 withAllHandles__ fun h@(DuplexHandle r w) act = do
 171   withHandle__' fun h r act
 172   withHandle__' fun h w act
 173
 174 withHandle__' fun h m act =
 175    block $ do
 176    h_ <- takeMVar m
 177    checkBufferInvariants h_
 178    h'  <- catchException (act h_)
 179                 (\ err -> putMVar m h_ >>
 180                           case err of
 181                               IOException ex -> ioError (augmentIOError ex fun h h_)
 182                               _ -> throw err)
 183    checkBufferInvariants h'
 184    putMVar m h'
 185    return ()
 186
 187 augmentIOError (IOError _ iot _ str fp) fun h h_
 188   = IOError (Just h) iot fun str filepath
 189   where filepath | Just _ <- fp = fp
 190                  | otherwise    = Just (haFilePath h_)
 191
 192 -- ---------------------------------------------------------------------------
 193 -- Wrapper for write operations.
 194
 195 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 196 wantWritableHandle fun h@(FileHandle m) act
 197   = wantWritableHandle' fun h m act
 198 wantWritableHandle fun h@(DuplexHandle _ m) act
 199   = wantWritableHandle' fun h m act
 200   -- ToDo: in the Duplex case, we don't need to checkWritableHandle
 201
 202 wantWritableHandle'
 203         :: String -> Handle -> MVar Handle__
 204         -> (Handle__ -> IO a) -> IO a
 205 wantWritableHandle' fun h m act
 206    = withHandle_' fun h m (checkWritableHandle act)
 207
 208 checkWritableHandle act handle_
 209   = case haType handle_ of
 210       ClosedHandle         -> ioe_closedHandle
 211       SemiClosedHandle     -> ioe_closedHandle
 212       ReadHandle           -> ioe_notWritable
 213       ReadWriteHandle      -> do
 214                 let ref = haBuffer handle_
 215                 buf <- readIORef ref
 216                 new_buf <-
 217                   if not (bufferIsWritable buf)
 218                      then do b <- flushReadBuffer (haFD handle_) buf
 219                              return b{ bufState=WriteBuffer }
 220                      else return buf
 221                 writeIORef ref new_buf
 222                 act handle_
 223       _other               -> act handle_
 224
 225 -- ---------------------------------------------------------------------------
 226 -- Wrapper for read operations.
 227
 228 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 229 wantReadableHandle fun h@(FileHandle   m)   act
 230   = wantReadableHandle' fun h m act
 231 wantReadableHandle fun h@(DuplexHandle m _) act
 232   = wantReadableHandle' fun h m act
 233   -- ToDo: in the Duplex case, we don't need to checkReadableHandle
 234
 235 wantReadableHandle'
 236         :: String -> Handle -> MVar Handle__
 237         -> (Handle__ -> IO a) -> IO a
 238 wantReadableHandle' fun h m act
 239   = withHandle_' fun h m (checkReadableHandle act)
 240
 241 checkReadableHandle act handle_ =
 242     case haType handle_ of
 243       ClosedHandle         -> ioe_closedHandle
 244       SemiClosedHandle     -> ioe_closedHandle
 245       AppendHandle         -> ioe_notReadable
 246       WriteHandle          -> ioe_notReadable
 247       ReadWriteHandle      -> do
 248         let ref = haBuffer handle_
 249         buf <- readIORef ref
 250         when (bufferIsWritable buf) $ do
 251            new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
 252            writeIORef ref new_buf{ bufState=ReadBuffer }
 253         act handle_
 254       _other               -> act handle_
 255
 256 -- ---------------------------------------------------------------------------
 257 -- Wrapper for seek operations.
 258
 259 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 260 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
 261   ioException (IOError (Just h) IllegalOperation fun
 262                    "handle is not seekable" Nothing)
 263 wantSeekableHandle fun h@(FileHandle m) act =
 264   withHandle_' fun h m (checkSeekableHandle act)
 265
 266 checkSeekableHandle act handle_ =
 267     case haType handle_ of
 268       ClosedHandle      -> ioe_closedHandle
 269       SemiClosedHandle  -> ioe_closedHandle
 270       AppendHandle      -> ioe_notSeekable
 271       _  | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
 272          | otherwise                                 -> ioe_notSeekable_notBin
 273
 274 -- -----------------------------------------------------------------------------
 275 -- Handy IOErrors
 276
 277 ioe_closedHandle, ioe_EOF,
 278   ioe_notReadable, ioe_notWritable,
 279   ioe_notSeekable, ioe_notSeekable_notBin :: IO a
 280
 281 ioe_closedHandle = ioException
 282    (IOError Nothing IllegalOperation ""
 283         "handle is closed" Nothing)
 284 ioe_EOF = ioException
 285    (IOError Nothing EOF "" "" Nothing)
 286 ioe_notReadable = ioException
 287    (IOError Nothing IllegalOperation ""
 288         "handle is not open for reading" Nothing)
 289 ioe_notWritable = ioException
 290    (IOError Nothing IllegalOperation ""
 291         "handle is not open for writing" Nothing)
 292 ioe_notSeekable = ioException
 293    (IOError Nothing IllegalOperation ""
 294         "handle is not seekable" Nothing)
 295 ioe_notSeekable_notBin = ioException
 296    (IOError Nothing IllegalOperation ""
 297       "seek operations on text-mode handles are not allowed on this platform"
 298         Nothing)
 299
 300 ioe_bufsiz :: Int -> IO a
 301 ioe_bufsiz n = ioException
 302    (IOError Nothing InvalidArgument "hSetBuffering"
 303         ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
 304                                 -- 9 => should be parens'ified.
 305
 306 -- -----------------------------------------------------------------------------
 307 -- Handle Finalizers
 308
 309 -- For a duplex handle, we arrange that the read side points to the write side
 310 -- (and hence keeps it alive if the read side is alive).  This is done by
 311 -- having the haOtherSide field of the read side point to the read side.
 312 -- The finalizer is then placed on the write side, and the handle only gets
 313 -- finalized once, when both sides are no longer required.
 314
 315 stdHandleFinalizer :: MVar Handle__ -> IO ()
 316 stdHandleFinalizer m = do
 317   h_ <- takeMVar m
 318   flushWriteBufferOnly h_
 319
 320 handleFinalizer :: MVar Handle__ -> IO ()
 321 handleFinalizer m = do
 322   handle_ <- takeMVar m
 323   case haType handle_ of
 324       ClosedHandle -> return ()
 325       _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
 326                 -- ignore errors and async exceptions, and close the
 327                 -- descriptor anyway...
 328               hClose_handle_ handle_
 329               return ()
 330
 331 -- ---------------------------------------------------------------------------
 332 -- Grimy buffer operations
 333
 334 #ifdef DEBUG
 335 checkBufferInvariants h_ = do
 336  let ref = haBuffer h_
 337  Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
 338  if not (
 339         size > 0
 340         && r <= w
 341         && w <= size
 342         && ( r /= w || (r == 0 && w == 0) )
 343         && ( state /= WriteBuffer || r == 0 )
 344         && ( state /= WriteBuffer || w < size ) -- write buffer is never full
 345      )
 346    then error "buffer invariant violation"
 347    else return ()
 348 #else
 349 checkBufferInvariants h_ = return ()
 350 #endif
 351
 352 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
 353 newEmptyBuffer b state size
 354   = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
 355
 356 allocateBuffer :: Int -> BufferState -> IO Buffer
 357 allocateBuffer sz@(I# size) state = IO $ \s ->
 358 #ifdef mingw32_TARGET_OS
 359    -- To implement asynchronous I/O under Win32, we have to pass
 360    -- buffer references to external threads that handles the
 361    -- filling/emptying of their contents. Hence, the buffer cannot
 362    -- be moved around by the GC.
 363   case newPinnedByteArray# size s of { (# s, b #) ->
 364 #else
 365   case newByteArray# size s of { (# s, b #) ->
 366 #endif
 367   (# s, newEmptyBuffer b state sz #) }
 368
 369 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
 370 writeCharIntoBuffer slab (I# off) (C# c)
 371   = IO $ \s -> case writeCharArray# slab off c s of
 372                  s -> (# s, I# (off +# 1#) #)
 373
 374 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
 375 readCharFromBuffer slab (I# off)
 376   = IO $ \s -> case readCharArray# slab off s of
 377                  (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
 378
 379 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
 380 getBuffer fd state = do
 381   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
 382   ioref  <- newIORef buffer
 383   is_tty <- fdIsTTY fd
 384
 385   let buffer_mode
 386          | is_tty    = LineBuffering
 387          | otherwise = BlockBuffering Nothing
 388
 389   return (ioref, buffer_mode)
 390
 391 mkUnBuffer :: IO (IORef Buffer)
 392 mkUnBuffer = do
 393   buffer <- allocateBuffer 1 ReadBuffer
 394   newIORef buffer
 395
 396 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
 397 flushWriteBufferOnly :: Handle__ -> IO ()
 398 flushWriteBufferOnly h_ = do
 399   let fd = haFD h_
 400       ref = haBuffer h_
 401   buf <- readIORef ref
 402   new_buf <- if bufferIsWritable buf
 403                 then flushWriteBuffer fd (haIsStream h_) buf
 404                 else return buf
 405   writeIORef ref new_buf
 406
 407 -- flushBuffer syncs the file with the buffer, including moving the
 408 -- file pointer backwards in the case of a read buffer.
 409 flushBuffer :: Handle__ -> IO ()
 410 flushBuffer h_ = do
 411   let ref = haBuffer h_
 412   buf <- readIORef ref
 413
 414   flushed_buf <-
 415     case bufState buf of
 416       ReadBuffer  -> flushReadBuffer  (haFD h_) buf
 417       WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
 418
 419   writeIORef ref flushed_buf
 420
 421 -- When flushing a read buffer, we seek backwards by the number of
 422 -- characters in the buffer.  The file descriptor must therefore be
 423 -- seekable: attempting to flush the read buffer on an unseekable
 424 -- handle is not allowed.
 425
 426 flushReadBuffer :: FD -> Buffer -> IO Buffer
 427 flushReadBuffer fd buf
 428   | bufferEmpty buf = return buf
 429   | otherwise = do
 430      let off = negate (bufWPtr buf - bufRPtr buf)
 431 #    ifdef DEBUG_DUMP
 432      puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
 433 #    endif
 434      throwErrnoIfMinus1Retry "flushReadBuffer"
 435          (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
 436      return buf{ bufWPtr=0, bufRPtr=0 }
 437
 438 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
 439 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  = do
 440   let bytes = w - r
 441 #ifdef DEBUG_DUMP
 442   puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
 443 #endif
 444   if bytes == 0
 445      then return (buf{ bufRPtr=0, bufWPtr=0 })
 446      else do
 447   res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
 448                         (fromIntegral r) (fromIntegral bytes)
 449   let res' = fromIntegral res
 450   if res' < bytes
 451      then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
 452      else return buf{ bufRPtr=0, bufWPtr=0 }
 453
 454 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
 455 fillReadBuffer fd is_line is_stream
 456       buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
 457   -- buffer better be empty:
 458   assert (r == 0 && w == 0) $ do
 459   fillReadBufferLoop fd is_line is_stream buf b w size
 460
 461 -- For a line buffer, we just get the first chunk of data to arrive,
 462 -- and don't wait for the whole buffer to be full (but we *do* wait
 463 -- until some data arrives).  This isn't really line buffering, but it
 464 -- appears to be what GHC has done for a long time, and I suspect it
 465 -- is more useful than line buffering in most cases.
 466
 467 fillReadBufferLoop fd is_line is_stream buf b w size = do
 468   let bytes = size - w
 469   if bytes == 0  -- buffer full?
 470      then return buf{ bufRPtr=0, bufWPtr=w }
 471      else do
 472 #ifdef DEBUG_DUMP
 473   puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
 474 #endif
 475   res <- readRawBuffer "fillReadBuffer" fd is_stream b
 476                        (fromIntegral w) (fromIntegral bytes)
 477   let res' = fromIntegral res
 478 #ifdef DEBUG_DUMP
 479   puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")
 480 #endif
 481   if res' == 0
 482      then if w == 0
 483              then ioe_EOF
 484              else return buf{ bufRPtr=0, bufWPtr=w }
 485      else if res' < bytes && not is_line
 486              then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
 487              else return buf{ bufRPtr=0, bufWPtr=w+res' }
 488
 489
 490 -- Low level routines for reading/writing to (raw)buffers:
 491
 492 #ifndef mingw32_TARGET_OS
 493 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 494 readRawBuffer loc fd is_stream buf off len =
 495   throwErrnoIfMinus1RetryMayBlock loc
 496             (read_rawBuffer fd is_stream buf off len)
 497             (threadWaitRead fd)
 498
 499 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 500 readRawBufferPtr loc fd is_stream buf off len =
 501   throwErrnoIfMinus1RetryMayBlock loc
 502             (read_off fd is_stream buf off len)
 503             (threadWaitRead fd)
 504
 505 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 506 writeRawBuffer loc fd is_stream buf off len =
 507   throwErrnoIfMinus1RetryMayBlock loc
 508                 (write_rawBuffer (fromIntegral fd) is_stream buf off len)
 509                 (threadWaitWrite fd)
 510
 511 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 512 writeRawBufferPtr loc fd is_stream buf off len =
 513   throwErrnoIfMinus1RetryMayBlock loc
 514                 (write_off (fromIntegral fd) is_stream buf off len)
 515                 (threadWaitWrite fd)
 516
 517 foreign import ccall unsafe "__hscore_PrelHandle_read"
 518    read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 519
 520 foreign import ccall unsafe "__hscore_PrelHandle_read"
 521    read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 522
 523 foreign import ccall unsafe "__hscore_PrelHandle_write"
 524    write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 525
 526 foreign import ccall unsafe "__hscore_PrelHandle_write"
 527    write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 528
 529 #else
 530 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 531 readRawBuffer loc fd is_stream buf off len = do
 532   (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
 533   if l == (-1)
 534    then
 535     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 536     else return (fromIntegral l)
 537
 538 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 539 readRawBufferPtr loc fd is_stream buf off len = do
 540   (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
 541   if l == (-1)
 542    then
 543     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 544     else return (fromIntegral l)
 545
 546 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 547 writeRawBuffer loc fd is_stream buf off len = do
 548   (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
 549   if l == (-1)
 550    then
 551     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 552     else return (fromIntegral l)
 553
 554 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 555 writeRawBufferPtr loc fd is_stream buf off len = do
 556   (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
 557   if l == (-1)
 558    then
 559     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 560     else return (fromIntegral l)
 561
 562 foreign import ccall unsafe "__hscore_PrelHandle_read"
 563    read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 564
 565 foreign import ccall unsafe "__hscore_PrelHandle_read"
 566    read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 567
 568 foreign import ccall unsafe "__hscore_PrelHandle_write"
 569    write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 570
 571 foreign import ccall unsafe "__hscore_PrelHandle_write"
 572    write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 573
 574 #endif
 575
 576 -- ---------------------------------------------------------------------------
 577 -- Standard Handles
 578
 579 -- Three handles are allocated during program initialisation.  The first
 580 -- two manage input or output from the Haskell program's standard input
 581 -- or output channel respectively.  The third manages output to the
 582 -- standard error channel. These handles are initially open.
 583
 584 fd_stdin  = 0 :: FD
 585 fd_stdout = 1 :: FD
 586 fd_stderr = 2 :: FD
 587
 588 stdin :: Handle
 589 stdin = unsafePerformIO $ do
 590    -- ToDo: acquire lock
 591    setNonBlockingFD fd_stdin
 592    (buf, bmode) <- getBuffer fd_stdin ReadBuffer
 593    mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
 594
 595 stdout :: Handle
 596 stdout = unsafePerformIO $ do
 597    -- ToDo: acquire lock
 598    -- We don't set non-blocking mode on stdout or sterr, because
 599    -- some shells don't recover properly.
 600    -- setNonBlockingFD fd_stdout
 601    (buf, bmode) <- getBuffer fd_stdout WriteBuffer
 602    mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
 603
 604 stderr :: Handle
 605 stderr = unsafePerformIO $ do
 606     -- ToDo: acquire lock
 607    -- We don't set non-blocking mode on stdout or sterr, because
 608    -- some shells don't recover properly.
 609    -- setNonBlockingFD fd_stderr
 610    buf <- mkUnBuffer
 611    mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
 612
 613 -- ---------------------------------------------------------------------------
 614 -- Opening and Closing Files
 615
 616 {-
 617 Computation `openFile file mode' allocates and returns a new, open
 618 handle to manage the file `file'.  It manages input if `mode'
 619 is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
 620 and both input and output if mode is `ReadWriteMode'.
 621
 622 If the file does not exist and it is opened for output, it should be
 623 created as a new file.  If `mode' is `WriteMode' and the file
 624 already exists, then it should be truncated to zero length.  The
 625 handle is positioned at the end of the file if `mode' is
 626 `AppendMode', and otherwise at the beginning (in which case its
 627 internal position is 0).
 628
 629 Implementations should enforce, locally to the Haskell process,
 630 multiple-reader single-writer locking on files, which is to say that
 631 there may either be many handles on the same file which manage input,
 632 or just one handle on the file which manages output.  If any open or
 633 semi-closed handle is managing a file for output, no new handle can be
 634 allocated for that file.  If any open or semi-closed handle is
 635 managing a file for input, new handles can only be allocated if they
 636 do not manage output.
 637
 638 Two files are the same if they have the same absolute name.  An
 639 implementation is free to impose stricter conditions.
 640 -}
 641
 642 addFilePathToIOError fun fp (IOError h iot _ str _)
 643   = IOError h iot fun str (Just fp)
 644
 645 openFile :: FilePath -> IOMode -> IO Handle
 646 openFile fp im =
 647   catch
 648     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
 649     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 650
 651 openBinaryFile :: FilePath -> IOMode -> IO Handle
 652 openBinaryFile fp m =
 653   catch
 654     (openFile' fp m True)
 655     (\e -> ioError (addFilePathToIOError "openFileEx" fp e))
 656
 657 openFile' filepath mode binary =
 658   withCString filepath $ \ f ->
 659
 660     let
 661       oflags1 = case mode of
 662                   ReadMode      -> read_flags
 663                   WriteMode     -> write_flags
 664                   ReadWriteMode -> rw_flags
 665                   AppendMode    -> append_flags
 666
 667       truncate | WriteMode <- mode = True
 668                | otherwise         = False
 669
 670       binary_flags
 671           | binary    = o_BINARY
 672           | otherwise = 0
 673
 674       oflags = oflags1 .|. binary_flags
 675     in do
 676
 677     -- the old implementation had a complicated series of three opens,
 678     -- which is perhaps because we have to be careful not to open
 679     -- directories.  However, the man pages I've read say that open()
 680     -- always returns EISDIR if the file is a directory and was opened
 681     -- for writing, so I think we're ok with a single open() here...
 682     fd <- fromIntegral `liftM`
 683               throwErrnoIfMinus1Retry "openFile"
 684                 (c_open f (fromIntegral oflags) 0o666)
 685
 686     openFd fd Nothing filepath mode binary truncate
 687         -- ASSERT: if we just created the file, then openFd won't fail
 688         -- (so we don't need to worry about removing the newly created file
 689         --  in the event of an error).
 690
 691
 692 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 693 output_flags = std_flags    .|. o_CREAT
 694 read_flags   = std_flags    .|. o_RDONLY
 695 write_flags  = output_flags .|. o_WRONLY
 696 rw_flags     = output_flags .|. o_RDWR
 697 append_flags = write_flags  .|. o_APPEND
 698
 699 -- ---------------------------------------------------------------------------
 700 -- openFd
 701
 702 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
 703 openFd fd mb_fd_type filepath mode binary truncate = do
 704     -- turn on non-blocking mode
 705     setNonBlockingFD fd
 706
 707     let (ha_type, write) =
 708           case mode of
 709             ReadMode      -> ( ReadHandle,      False )
 710             WriteMode     -> ( WriteHandle,     True )
 711             ReadWriteMode -> ( ReadWriteHandle, True )
 712             AppendMode    -> ( AppendHandle,    True )
 713
 714     -- open() won't tell us if it was a directory if we only opened for
 715     -- reading, so check again.
 716     fd_type <-
 717       case mb_fd_type of
 718         Just x  -> return x
 719         Nothing -> fdType fd
 720     let is_stream = fd_type == Stream
 721     case fd_type of
 722         Directory ->
 723            ioException (IOError Nothing InappropriateType "openFile"
 724                            "is a directory" Nothing)
 725
 726         Stream
 727            | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
 728            | otherwise                  -> mkFileHandle fd is_stream filepath ha_type binary
 729
 730         -- regular files need to be locked
 731         RegularFile -> do
 732            r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 733            when (r == -1)  $
 734                 ioException (IOError Nothing ResourceBusy "openFile"
 735                                    "file is locked" Nothing)
 736
 737            -- truncate the file if necessary
 738            when truncate (fileTruncate filepath)
 739
 740            mkFileHandle fd is_stream filepath ha_type binary
 741
 742
 743 fdToHandle :: FD -> IO Handle
 744 fdToHandle fd = do
 745    mode <- fdGetMode fd
 746    let fd_str = "<file descriptor: " ++ show fd ++ ">"
 747    openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
 748
 749 foreign import ccall unsafe "lockFile"
 750   lockFile :: CInt -> CInt -> CInt -> IO CInt
 751
 752 foreign import ccall unsafe "unlockFile"
 753   unlockFile :: CInt -> IO CInt
 754
 755 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
 756         -> IO Handle
 757 mkStdHandle fd filepath ha_type buf bmode = do
 758    spares <- newIORef BufferListNil
 759    newFileHandle stdHandleFinalizer
 760             (Handle__ { haFD = fd,
 761                         haType = ha_type,
 762                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
 763                         haIsStream = False,
 764                         haBufferMode = bmode,
 765                         haFilePath = filepath,
 766                         haBuffer = buf,
 767                         haBuffers = spares,
 768                         haOtherSide = Nothing
 769                       })
 770
 771 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 772 mkFileHandle fd is_stream filepath ha_type binary = do
 773   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 774   spares <- newIORef BufferListNil
 775   newFileHandle handleFinalizer
 776             (Handle__ { haFD = fd,
 777                         haType = ha_type,
 778                         haIsBin = binary,
 779                         haIsStream = is_stream,
 780                         haBufferMode = bmode,
 781                         haFilePath = filepath,
 782                         haBuffer = buf,
 783                         haBuffers = spares,
 784                         haOtherSide = Nothing
 785                       })
 786
 787 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
 788 mkDuplexHandle fd is_stream filepath binary = do
 789   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 790   w_spares <- newIORef BufferListNil
 791   let w_handle_ =
 792              Handle__ { haFD = fd,
 793                         haType = WriteHandle,
 794                         haIsBin = binary,
 795                         haIsStream = is_stream,
 796                         haBufferMode = w_bmode,
 797                         haFilePath = filepath,
 798                         haBuffer = w_buf,
 799                         haBuffers = w_spares,
 800                         haOtherSide = Nothing
 801                       }
 802   write_side <- newMVar w_handle_
 803
 804   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 805   r_spares <- newIORef BufferListNil
 806   let r_handle_ =
 807              Handle__ { haFD = fd,
 808                         haType = ReadHandle,
 809                         haIsBin = binary,
 810                         haIsStream = is_stream,
 811                         haBufferMode = r_bmode,
 812                         haFilePath = filepath,
 813                         haBuffer = r_buf,
 814                         haBuffers = r_spares,
 815                         haOtherSide = Just write_side
 816                       }
 817   read_side <- newMVar r_handle_
 818
 819   addMVarFinalizer write_side (handleFinalizer write_side)
 820   return (DuplexHandle read_side write_side)
 821
 822
 823 initBufferState ReadHandle = ReadBuffer
 824 initBufferState _          = WriteBuffer
 825
 826 -- ---------------------------------------------------------------------------
 827 -- Closing a handle
 828
 829 -- Computation `hClose hdl' makes handle `hdl' closed.  Before the
 830 -- computation finishes, any items buffered for output and not already
 831 -- sent to the operating system are flushed as for `hFlush'.
 832
 833 -- For a duplex handle, we close&flush the write side, and just close
 834 -- the read side.
 835
 836 hClose :: Handle -> IO ()
 837 hClose h@(FileHandle m)     = hClose' h m
 838 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
 839
 840 hClose' h m = withHandle__' "hClose" h m $ hClose_help
 841
 842 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
 843 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
 844 -- then closed immediately.  We have to be careful with DuplexHandles
 845 -- though: we have to leave the closing to the finalizer in that case,
 846 -- because the write side may still be in use.
 847 hClose_help :: Handle__ -> IO Handle__
 848 hClose_help handle_ =
 849   case haType handle_ of
 850       ClosedHandle -> return handle_
 851       _ -> do flushWriteBufferOnly handle_ -- interruptible
 852               hClose_handle_ handle_
 853
 854 hClose_handle_ handle_ = do
 855     let fd = haFD handle_
 856         c_fd = fromIntegral fd
 857
 858     -- close the file descriptor, but not when this is the read
 859     -- side of a duplex handle, and not when this is one of the
 860     -- std file handles.
 861     case haOtherSide handle_ of
 862       Nothing ->
 863           when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
 864                   throwErrnoIfMinus1Retry_ "hClose"
 865 #ifdef mingw32_TARGET_OS
 866                                 (closeFd (haIsStream handle_) c_fd)
 867 #else
 868                                 (c_close c_fd)
 869 #endif
 870       Just _  -> return ()
 871
 872     -- free the spare buffers
 873     writeIORef (haBuffers handle_) BufferListNil
 874
 875     -- unlock it
 876     unlockFile c_fd
 877
 878     -- we must set the fd to -1, because the finalizer is going
 879     -- to run eventually and try to close/unlock it.
 880     return (handle_{ haFD        = -1,
 881                      haType      = ClosedHandle
 882                    })
 883
 884 -----------------------------------------------------------------------------
 885 -- Detecting the size of a file
 886
 887 -- For a handle `hdl' which attached to a physical file, `hFileSize
 888 -- hdl' returns the size of `hdl' in terms of the number of items
 889 -- which can be read from `hdl'.
 890
 891 hFileSize :: Handle -> IO Integer
 892 hFileSize handle =
 893     withHandle_ "hFileSize" handle $ \ handle_ -> do
 894     case haType handle_ of
 895       ClosedHandle              -> ioe_closedHandle
 896       SemiClosedHandle          -> ioe_closedHandle
 897       _ -> do flushWriteBufferOnly handle_
 898               r <- fdFileSize (haFD handle_)
 899               if r /= -1
 900                  then return r
 901                  else ioException (IOError Nothing InappropriateType "hFileSize"
 902                                    "not a regular file" Nothing)
 903
 904 -- ---------------------------------------------------------------------------
 905 -- Detecting the End of Input
 906
 907 -- For a readable handle `hdl', `hIsEOF hdl' returns
 908 -- `True' if no further input can be taken from `hdl' or for a
 909 -- physical file, if the current I/O position is equal to the length of
 910 -- the file.  Otherwise, it returns `False'.
 911
 912 hIsEOF :: Handle -> IO Bool
 913 hIsEOF handle =
 914   catch
 915      (do hLookAhead handle; return False)
 916      (\e -> if isEOFError e then return True else ioError e)
 917
 918 isEOF :: IO Bool
 919 isEOF = hIsEOF stdin
 920
 921 -- ---------------------------------------------------------------------------
 922 -- Looking ahead
 923
 924 -- hLookahead returns the next character from the handle without
 925 -- removing it from the input buffer, blocking until a character is
 926 -- available.
 927
 928 hLookAhead :: Handle -> IO Char
 929 hLookAhead handle = do
 930   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 931   let ref     = haBuffer handle_
 932       fd      = haFD handle_
 933       is_line = haBufferMode handle_ == LineBuffering
 934   buf <- readIORef ref
 935
 936   -- fill up the read buffer if necessary
 937   new_buf <- if bufferEmpty buf
 938                 then fillReadBuffer fd is_line (haIsStream handle_) buf
 939                 else return buf
 940
 941   writeIORef ref new_buf
 942
 943   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 944   return c
 945
 946 -- ---------------------------------------------------------------------------
 947 -- Buffering Operations
 948
 949 -- Three kinds of buffering are supported: line-buffering,
 950 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
 951 -- further explanation of what the type represent.
 952
 953 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 954 -- handle hdl on subsequent reads and writes.
 955 --
 956 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 957 --
 958 --   * If mode is `BlockBuffering size', then block-buffering
 959 --     should be enabled if possible.  The size of the buffer is n items
 960 --     if size is `Just n' and is otherwise implementation-dependent.
 961 --
 962 --   * If mode is NoBuffering, then buffering is disabled if possible.
 963
 964 -- If the buffer mode is changed from BlockBuffering or
 965 -- LineBuffering to NoBuffering, then any items in the output
 966 -- buffer are written to the device, and any items in the input buffer
 967 -- are discarded.  The default buffering mode when a handle is opened
 968 -- is implementation-dependent and may depend on the object which is
 969 -- attached to that handle.
 970
 971 hSetBuffering :: Handle -> BufferMode -> IO ()
 972 hSetBuffering handle mode =
 973   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 974   case haType handle_ of
 975     ClosedHandle -> ioe_closedHandle
 976     _ -> do
 977          {- Note:
 978             - we flush the old buffer regardless of whether
 979               the new buffer could fit the contents of the old buffer
 980               or not.
 981             - allow a handle's buffering to change even if IO has
 982               occurred (ANSI C spec. does not allow this, nor did
 983               the previous implementation of IO.hSetBuffering).
 984             - a non-standard extension is to allow the buffering
 985               of semi-closed handles to change [sof 6/98]
 986           -}
 987           flushBuffer handle_
 988
 989           let state = initBufferState (haType handle_)
 990           new_buf <-
 991             case mode of
 992                 -- we always have a 1-character read buffer for
 993                 -- unbuffered  handles: it's needed to
 994                 -- support hLookAhead.
 995               NoBuffering            -> allocateBuffer 1 ReadBuffer
 996               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 997               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 998               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 999                                       | otherwise -> allocateBuffer n state
1000           writeIORef (haBuffer handle_) new_buf
1001
1002           -- for input terminals we need to put the terminal into
1003           -- cooked or raw mode depending on the type of buffering.
1004           is_tty <- fdIsTTY (haFD handle_)
1005           when (is_tty && isReadableHandleType (haType handle_)) $
1006                 case mode of
1007 #ifndef mingw32_TARGET_OS
1008         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1009         -- for most common uses), so simply disable its use here.
1010                   NoBuffering -> setCooked (haFD handle_) False
1011 #endif
1012                   _           -> setCooked (haFD handle_) True
1013
1014           -- throw away spare buffers, they might be the wrong size
1015           writeIORef (haBuffers handle_) BufferListNil
1016
1017           return (handle_{ haBufferMode = mode })
1018
1019 -- -----------------------------------------------------------------------------
1020 -- hFlush
1021
1022 -- The action `hFlush hdl' causes any items buffered for output
1023 -- in handle `hdl' to be sent immediately to the operating
1024 -- system.
1025
1026 hFlush :: Handle -> IO ()
1027 hFlush handle =
1028    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1029    buf <- readIORef (haBuffer handle_)
1030    if bufferIsWritable buf && not (bufferEmpty buf)
1031         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1032                 writeIORef (haBuffer handle_) flushed_buf
1033         else return ()
1034
1035
1036 -- -----------------------------------------------------------------------------
1037 -- Repositioning Handles
1038
1039 data HandlePosn = HandlePosn Handle HandlePosition
1040
1041 instance Eq HandlePosn where
1042     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1043
1044 instance Show HandlePosn where
1045    showsPrec p (HandlePosn h pos) =
1046         showsPrec p h . showString " at position " . shows pos
1047
1048   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1049   -- We represent it as an Integer on the Haskell side, but
1050   -- cheat slightly in that hGetPosn calls upon a C helper
1051   -- that reports the position back via (merely) an Int.
1052 type HandlePosition = Integer
1053
1054 -- Computation `hGetPosn hdl' returns the current I/O position of
1055 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
1056 -- position of `hdl' to a previously obtained position `p'.
1057
1058 hGetPosn :: Handle -> IO HandlePosn
1059 hGetPosn handle = do
1060     posn <- hTell handle
1061     return (HandlePosn handle posn)
1062
1063 hSetPosn :: HandlePosn -> IO ()
1064 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1065
1066 -- ---------------------------------------------------------------------------
1067 -- hSeek
1068
1069 {-
1070 The action `hSeek hdl mode i' sets the position of handle
1071 `hdl' depending on `mode'.  If `mode' is
1072
1073  * AbsoluteSeek - The position of `hdl' is set to `i'.
1074  * RelativeSeek - The position of `hdl' is set to offset `i' from
1075                   the current position.
1076  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
1077                   the end of the file.
1078
1079 Some handles may not be seekable (see `hIsSeekable'), or only
1080 support a subset of the possible positioning operations (e.g. it may
1081 only be possible to seek to the end of a tape, or to a positive
1082 offset from the beginning or current position).
1083
1084 It is not possible to set a negative I/O position, or for a physical
1085 file, an I/O position beyond the current end-of-file.
1086
1087 Note:
1088  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1089    seeking at or past EOF.
1090
1091  - we possibly deviate from the report on the issue of seeking within
1092    the buffer and whether to flush it or not.  The report isn't exactly
1093    clear here.
1094 -}
1095
1096 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
1097                     deriving (Eq, Ord, Ix, Enum, Read, Show)
1098
1099 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1100 hSeek handle mode offset =
1101     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1102 #   ifdef DEBUG_DUMP
1103     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1104 #   endif
1105     let ref = haBuffer handle_
1106     buf <- readIORef ref
1107     let r = bufRPtr buf
1108         w = bufWPtr buf
1109         fd = haFD handle_
1110
1111     let do_seek =
1112           throwErrnoIfMinus1Retry_ "hSeek"
1113             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1114
1115         whence :: CInt
1116         whence = case mode of
1117                    AbsoluteSeek -> sEEK_SET
1118                    RelativeSeek -> sEEK_CUR
1119                    SeekFromEnd  -> sEEK_END
1120
1121     if bufferIsWritable buf
1122         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1123                 writeIORef ref new_buf
1124                 do_seek
1125         else do
1126
1127     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1128         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1129         else do
1130
1131     new_buf <- flushReadBuffer (haFD handle_) buf
1132     writeIORef ref new_buf
1133     do_seek
1134
1135
1136 hTell :: Handle -> IO Integer
1137 hTell handle =
1138     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1139
1140 #if defined(mingw32_TARGET_OS)
1141         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1142         -- so we can't easily calculate the file position using the
1143         -- current buffer size.  Just flush instead.
1144       flushBuffer handle_
1145 #endif
1146       let fd = fromIntegral (haFD handle_)
1147       posn <- fromIntegral `liftM`
1148                 throwErrnoIfMinus1Retry "hGetPosn"
1149                    (c_lseek fd 0 sEEK_CUR)
1150
1151       let ref = haBuffer handle_
1152       buf <- readIORef ref
1153
1154       let real_posn
1155            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1156            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1157 #     ifdef DEBUG_DUMP
1158       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1159       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1160 #     endif
1161       return real_posn
1162
1163 -- -----------------------------------------------------------------------------
1164 -- Handle Properties
1165
1166 -- A number of operations return information about the properties of a
1167 -- handle.  Each of these operations returns `True' if the handle has
1168 -- the specified property, and `False' otherwise.
1169
1170 hIsOpen :: Handle -> IO Bool
1171 hIsOpen handle =
1172     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1173     case haType handle_ of
1174       ClosedHandle         -> return False
1175       SemiClosedHandle     -> return False
1176       _                    -> return True
1177
1178 hIsClosed :: Handle -> IO Bool
1179 hIsClosed handle =
1180     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1181     case haType handle_ of
1182       ClosedHandle         -> return True
1183       _                    -> return False
1184
1185 {- not defined, nor exported, but mentioned
1186    here for documentation purposes:
1187
1188     hSemiClosed :: Handle -> IO Bool
1189     hSemiClosed h = do
1190        ho <- hIsOpen h
1191        hc <- hIsClosed h
1192        return (not (ho || hc))
1193 -}
1194
1195 hIsReadable :: Handle -> IO Bool
1196 hIsReadable (DuplexHandle _ _) = return True
1197 hIsReadable handle =
1198     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1199     case haType handle_ of
1200       ClosedHandle         -> ioe_closedHandle
1201       SemiClosedHandle     -> ioe_closedHandle
1202       htype                -> return (isReadableHandleType htype)
1203
1204 hIsWritable :: Handle -> IO Bool
1205 hIsWritable (DuplexHandle _ _) = return False
1206 hIsWritable handle =
1207     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1208     case haType handle_ of
1209       ClosedHandle         -> ioe_closedHandle
1210       SemiClosedHandle     -> ioe_closedHandle
1211       htype                -> return (isWritableHandleType htype)
1212
1213 -- Querying how a handle buffers its data:
1214
1215 hGetBuffering :: Handle -> IO BufferMode
1216 hGetBuffering handle =
1217     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1218     case haType handle_ of
1219       ClosedHandle         -> ioe_closedHandle
1220       _ ->
1221            -- We're being non-standard here, and allow the buffering
1222            -- of a semi-closed handle to be queried.   -- sof 6/98
1223           return (haBufferMode handle_)  -- could be stricter..
1224
1225 hIsSeekable :: Handle -> IO Bool
1226 hIsSeekable handle =
1227     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1228     case haType handle_ of
1229       ClosedHandle         -> ioe_closedHandle
1230       SemiClosedHandle     -> ioe_closedHandle
1231       AppendHandle         -> return False
1232       _                    -> do t <- fdType (haFD handle_)
1233                                  return (t == RegularFile
1234                                          && (haIsBin handle_
1235                                                 || tEXT_MODE_SEEK_ALLOWED))
1236
1237 -- -----------------------------------------------------------------------------
1238 -- Changing echo status (Non-standard GHC extensions)
1239
1240 -- | Set the echoing status of a handle connected to a terminal (GHC only).
1241
1242 hSetEcho :: Handle -> Bool -> IO ()
1243 hSetEcho handle on = do
1244     isT   <- hIsTerminalDevice handle
1245     if not isT
1246      then return ()
1247      else
1248       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1249       case haType handle_ of
1250          ClosedHandle -> ioe_closedHandle
1251          _            -> setEcho (haFD handle_) on
1252
1253 -- | Get the echoing status of a handle connected to a terminal (GHC only).
1254
1255 hGetEcho :: Handle -> IO Bool
1256 hGetEcho handle = do
1257     isT   <- hIsTerminalDevice handle
1258     if not isT
1259      then return False
1260      else
1261        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1262        case haType handle_ of
1263          ClosedHandle -> ioe_closedHandle
1264          _            -> getEcho (haFD handle_)
1265
1266 -- | Is the handle connected to a terminal? (GHC only)
1267
1268 hIsTerminalDevice :: Handle -> IO Bool
1269 hIsTerminalDevice handle = do
1270     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1271      case haType handle_ of
1272        ClosedHandle -> ioe_closedHandle
1273        _            -> fdIsTTY (haFD handle_)
1274
1275 -- -----------------------------------------------------------------------------
1276 -- hSetBinaryMode
1277
1278 -- | On Windows, reading a file in text mode (which is the default) will
1279 -- translate CRLF to LF, and writing will translate LF to CRLF. This
1280 -- is usually what you want with text files. With binary files this is
1281 -- undesirable; also, as usual under Microsoft operating systems, text
1282 -- mode treats control-Z as EOF.  Setting binary mode using
1283 -- 'hSetBinaryMode' turns off all special treatment of end-of-line and
1284 -- end-of-file characters.
1285 --
1286 hSetBinaryMode :: Handle -> Bool -> IO ()
1287 hSetBinaryMode handle bin =
1288   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1289     do throwErrnoIfMinus1_ "hSetBinaryMode"
1290           (setmode (fromIntegral (haFD handle_)) bin)
1291        return handle_{haIsBin=bin}
1292
1293 foreign import ccall unsafe "__hscore_setmode"
1294   setmode :: CInt -> Bool -> IO CInt
1295
1296 -- -----------------------------------------------------------------------------
1297 -- Duplicating a Handle
1298
1299 -- |Returns a duplicate of the original handle, with its own buffer
1300 -- and file pointer.  The original handle's buffer is flushed, including
1301 -- discarding any input data, before the handle is duplicated.
1302
1303 hDuplicate :: Handle -> IO Handle
1304 hDuplicate h@(FileHandle m) = do
1305   new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1306   new_m <- newMVar new_h_
1307   return (FileHandle new_m)
1308 hDuplicate h@(DuplexHandle r w) = do
1309   new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1310   new_w <- newMVar new_w_
1311   new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1312   new_r <- newMVar new_r_
1313   return (DuplexHandle new_r new_w)
1314
1315 dupHandle_ other_side h_ = do
1316   -- flush the buffer first, so we don't have to copy its contents
1317   flushBuffer h_
1318   new_fd <- c_dup (fromIntegral (haFD h_))
1319   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1320   ioref <- newIORef buffer
1321   ioref_buffers <- newIORef BufferListNil
1322
1323   let new_handle_ = h_{ haFD = fromIntegral new_fd,
1324                         haBuffer = ioref,
1325                         haBuffers = ioref_buffers,
1326                         haOtherSide = other_side }
1327   return (h_, new_handle_)
1328
1329 -- -----------------------------------------------------------------------------
1330 -- Replacing a Handle
1331
1332 {- |
1333 Makes the second handle a duplicate of the first handle.  The second
1334 handle will be closed first, if it is not already.
1335
1336 This can be used to retarget the standard Handles, for example:
1337
1338 > do h <- openFile "mystdout" WriteMode
1339 >    hDuplicateTo h stdout
1340 -}
1341
1342 hDuplicateTo :: Handle -> Handle -> IO ()
1343 hDuplicateTo h1@(FileHandle m1) h2@(FileHandle m2)  = do
1344  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1345    _ <- hClose_help h2_
1346    withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1347 hDuplicateTo h1@(DuplexHandle r1 w1) h2@(DuplexHandle r2 w2)  = do
1348  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1349    _ <- hClose_help w2_
1350    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1351  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1352    _ <- hClose_help r2_
1353    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1354 hDuplicateTo h1 _ =
1355    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1356                 "handles are incompatible" Nothing)
1357
1358 -- ---------------------------------------------------------------------------
1359 -- debugging
1360
1361 #ifdef DEBUG_DUMP
1362 puts :: String -> IO ()
1363 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1364                                      return ()
1365 #endif
1366
1367 -- -----------------------------------------------------------------------------
1368 -- wrappers to platform-specific constants:
1369
1370 foreign import ccall unsafe "__hscore_supportsTextMode"
1371   tEXT_MODE_SEEK_ALLOWED :: Bool
1372
1373 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1374 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1375 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1376 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt