GHC/Handle.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
   2 {-# OPTIONS_HADDOCK hide #-}
   3
   4 #undef DEBUG_DUMP
   5 #undef DEBUG
   6
   7 -----------------------------------------------------------------------------
   8 -- |
   9 -- Module      :  GHC.Handle
  10 -- Copyright   :  (c) The University of Glasgow, 1994-2001
  11 -- License     :  see libraries/base/LICENSE
  12 --
  13 -- Maintainer  :  libraries@haskell.org
  14 -- Stability   :  internal
  15 -- Portability :  non-portable
  16 --
  17 -- This module defines the basic operations on I\/O \"handles\".
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 -- #hide
  22 module GHC.Handle (
  23   withHandle, withHandle', withHandle_,
  24   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
  25
  26   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  27   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
  28   fillReadBuffer, fillReadBufferWithoutBlocking,
  29   readRawBuffer, readRawBufferPtr,
  30   readRawBufferNoBlock, readRawBufferPtrNoBlock,
  31   writeRawBuffer, writeRawBufferPtr,
  32
  33 #ifndef mingw32_HOST_OS
  34   unlockFile,
  35 #endif
  36
  37   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
  38
  39   stdin, stdout, stderr,
  40   IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
  41   hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
  42   hFlush, hDuplicate, hDuplicateTo,
  43
  44   hClose, hClose_help,
  45
  46   HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  47   SeekMode(..), hSeek, hTell,
  48
  49   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  50   hSetEcho, hGetEcho, hIsTerminalDevice,
  51
  52   hShow,
  53
  54 #ifdef DEBUG_DUMP
  55   puts,
  56 #endif
  57
  58  ) where
  59
  60 import Control.Monad
  61 import Data.Maybe
  62 import Foreign
  63 import Foreign.C
  64 import System.IO.Error
  65 import System.Posix.Internals
  66 import System.Posix.Types
  67
  68 import GHC.Real
  69
  70 import GHC.Arr
  71 import GHC.Base
  72 import GHC.Read         ( Read )
  73 import GHC.List
  74 import GHC.IOBase
  75 import GHC.Exception
  76 import GHC.Enum
  77 import GHC.Num          ( Integer(..), Num(..) )
  78 import GHC.Show
  79 #if defined(DEBUG_DUMP)
  80 import GHC.Pack
  81 #endif
  82
  83 import GHC.Conc
  84
  85 -- -----------------------------------------------------------------------------
  86 -- TODO:
  87
  88 -- hWaitForInput blocks (should use a timeout)
  89
  90 -- unbuffered hGetLine is a bit dodgy
  91
  92 -- hSetBuffering: can't change buffering on a stream,
  93 --      when the read buffer is non-empty? (no way to flush the buffer)
  94
  95 -- ---------------------------------------------------------------------------
  96 -- Are files opened by default in text or binary mode, if the user doesn't
  97 -- specify?
  98
  99 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
 100
 101 -- ---------------------------------------------------------------------------
 102 -- Creating a new handle
 103
 104 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
 105 newFileHandle filepath finalizer hc = do
 106   m <- newMVar hc
 107   addMVarFinalizer m (finalizer m)
 108   return (FileHandle filepath m)
 109
 110 -- ---------------------------------------------------------------------------
 111 -- Working with Handles
 112
 113 {-
 114 In the concurrent world, handles are locked during use.  This is done
 115 by wrapping an MVar around the handle which acts as a mutex over
 116 operations on the handle.
 117
 118 To avoid races, we use the following bracketing operations.  The idea
 119 is to obtain the lock, do some operation and replace the lock again,
 120 whether the operation succeeded or failed.  We also want to handle the
 121 case where the thread receives an exception while processing the IO
 122 operation: in these cases we also want to relinquish the lock.
 123
 124 There are three versions of @withHandle@: corresponding to the three
 125 possible combinations of:
 126
 127         - the operation may side-effect the handle
 128         - the operation may return a result
 129
 130 If the operation generates an error or an exception is raised, the
 131 original handle is always replaced [ this is the case at the moment,
 132 but we might want to revisit this in the future --SDM ].
 133 -}
 134
 135 {-# INLINE withHandle #-}
 136 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 137 withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act
 138 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
 139
 140 withHandle' :: String -> Handle -> MVar Handle__
 141    -> (Handle__ -> IO (Handle__,a)) -> IO a
 142 withHandle' fun h m act =
 143    block $ do
 144    h_ <- takeMVar m
 145    checkBufferInvariants h_
 146    (h',v)  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
 147               `catchException` \ex -> ioError (augmentIOError ex fun h)
 148    checkBufferInvariants h'
 149    putMVar m h'
 150    return v
 151
 152 {-# INLINE withHandle_ #-}
 153 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 154 withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
 155 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
 156
 157 withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
 158 withHandle_' fun h m act =
 159    block $ do
 160    h_ <- takeMVar m
 161    checkBufferInvariants h_
 162    v  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
 163          `catchException` \ex -> ioError (augmentIOError ex fun h)
 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'  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
 179           `catchException` \ex -> ioError (augmentIOError ex fun h)
 180    checkBufferInvariants h'
 181    putMVar m h'
 182    return ()
 183
 184 augmentIOError (IOError _ iot _ str fp) fun h
 185   = IOError (Just h) iot fun str filepath
 186   where filepath
 187           | Just _ <- fp = fp
 188           | otherwise = case h of
 189                           FileHandle fp _     -> Just fp
 190                           DuplexHandle fp _ _ -> Just fp
 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_finalizedHandle fp = throw
 301    (IOError Nothing IllegalOperation ""
 302         "handle is finalized" (Just fp))
 303
 304 ioe_bufsiz :: Int -> IO a
 305 ioe_bufsiz n = ioException
 306    (IOError Nothing InvalidArgument "hSetBuffering"
 307         ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
 308                                 -- 9 => should be parens'ified.
 309
 310 -- -----------------------------------------------------------------------------
 311 -- Handle Finalizers
 312
 313 -- For a duplex handle, we arrange that the read side points to the write side
 314 -- (and hence keeps it alive if the read side is alive).  This is done by
 315 -- having the haOtherSide field of the read side point to the read side.
 316 -- The finalizer is then placed on the write side, and the handle only gets
 317 -- finalized once, when both sides are no longer required.
 318
 319 -- NOTE about finalized handles: It's possible that a handle can be
 320 -- finalized and then we try to use it later, for example if the
 321 -- handle is referenced from another finalizer, or from a thread that
 322 -- has become unreferenced and then resurrected (arguably in the
 323 -- latter case we shouldn't finalize the Handle...).  Anyway,
 324 -- we try to emit a helpful message which is better than nothing.
 325
 326 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
 327 stdHandleFinalizer fp m = do
 328   h_ <- takeMVar m
 329   flushWriteBufferOnly h_
 330   putMVar m (ioe_finalizedHandle fp)
 331
 332 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
 333 handleFinalizer fp m = do
 334   handle_ <- takeMVar m
 335   case haType handle_ of
 336       ClosedHandle -> return ()
 337       _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
 338                 -- ignore errors and async exceptions, and close the
 339                 -- descriptor anyway...
 340               hClose_handle_ handle_
 341               return ()
 342   putMVar m (ioe_finalizedHandle fp)
 343
 344 -- ---------------------------------------------------------------------------
 345 -- Grimy buffer operations
 346
 347 #ifdef DEBUG
 348 checkBufferInvariants h_ = do
 349  let ref = haBuffer h_
 350  Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
 351  if not (
 352         size > 0
 353         && r <= w
 354         && w <= size
 355         && ( r /= w || (r == 0 && w == 0) )
 356         && ( state /= WriteBuffer || r == 0 )
 357         && ( state /= WriteBuffer || w < size ) -- write buffer is never full
 358      )
 359    then error "buffer invariant violation"
 360    else return ()
 361 #else
 362 checkBufferInvariants h_ = return ()
 363 #endif
 364
 365 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
 366 newEmptyBuffer b state size
 367   = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
 368
 369 allocateBuffer :: Int -> BufferState -> IO Buffer
 370 allocateBuffer sz@(I# size) state = IO $ \s ->
 371    -- We sometimes need to pass the address of this buffer to
 372    -- a "safe" foreign call, hence it must be immovable.
 373   case newPinnedByteArray# size s of { (# s, b #) ->
 374   (# s, newEmptyBuffer b state sz #) }
 375
 376 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
 377 writeCharIntoBuffer slab (I# off) (C# c)
 378   = IO $ \s -> case writeCharArray# slab off c s of
 379                  s -> (# s, I# (off +# 1#) #)
 380
 381 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
 382 readCharFromBuffer slab (I# off)
 383   = IO $ \s -> case readCharArray# slab off s of
 384                  (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
 385
 386 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
 387 getBuffer fd state = do
 388   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
 389   ioref  <- newIORef buffer
 390   is_tty <- fdIsTTY fd
 391
 392   let buffer_mode
 393          | is_tty    = LineBuffering
 394          | otherwise = BlockBuffering Nothing
 395
 396   return (ioref, buffer_mode)
 397
 398 mkUnBuffer :: IO (IORef Buffer)
 399 mkUnBuffer = do
 400   buffer <- allocateBuffer 1 ReadBuffer
 401   newIORef buffer
 402
 403 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
 404 flushWriteBufferOnly :: Handle__ -> IO ()
 405 flushWriteBufferOnly h_ = do
 406   let fd = haFD h_
 407       ref = haBuffer h_
 408   buf <- readIORef ref
 409   new_buf <- if bufferIsWritable buf
 410                 then flushWriteBuffer fd (haIsStream h_) buf
 411                 else return buf
 412   writeIORef ref new_buf
 413
 414 -- flushBuffer syncs the file with the buffer, including moving the
 415 -- file pointer backwards in the case of a read buffer.
 416 flushBuffer :: Handle__ -> IO ()
 417 flushBuffer h_ = do
 418   let ref = haBuffer h_
 419   buf <- readIORef ref
 420
 421   flushed_buf <-
 422     case bufState buf of
 423       ReadBuffer  -> flushReadBuffer  (haFD h_) buf
 424       WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
 425
 426   writeIORef ref flushed_buf
 427
 428 -- When flushing a read buffer, we seek backwards by the number of
 429 -- characters in the buffer.  The file descriptor must therefore be
 430 -- seekable: attempting to flush the read buffer on an unseekable
 431 -- handle is not allowed.
 432
 433 flushReadBuffer :: FD -> Buffer -> IO Buffer
 434 flushReadBuffer fd buf
 435   | bufferEmpty buf = return buf
 436   | otherwise = do
 437      let off = negate (bufWPtr buf - bufRPtr buf)
 438 #    ifdef DEBUG_DUMP
 439      puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
 440 #    endif
 441      throwErrnoIfMinus1Retry "flushReadBuffer"
 442          (c_lseek fd (fromIntegral off) sEEK_CUR)
 443      return buf{ bufWPtr=0, bufRPtr=0 }
 444
 445 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
 446 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =
 447   seq fd $ do -- strictness hack
 448   let bytes = w - r
 449 #ifdef DEBUG_DUMP
 450   puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
 451 #endif
 452   if bytes == 0
 453      then return (buf{ bufRPtr=0, bufWPtr=0 })
 454      else do
 455   res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
 456                         (fromIntegral r) (fromIntegral bytes)
 457   let res' = fromIntegral res
 458   if res' < bytes
 459      then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
 460      else return buf{ bufRPtr=0, bufWPtr=0 }
 461
 462 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
 463 fillReadBuffer fd is_line is_stream
 464       buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
 465   -- buffer better be empty:
 466   assert (r == 0 && w == 0) $ do
 467   fillReadBufferLoop fd is_line is_stream buf b w size
 468
 469 -- For a line buffer, we just get the first chunk of data to arrive,
 470 -- and don't wait for the whole buffer to be full (but we *do* wait
 471 -- until some data arrives).  This isn't really line buffering, but it
 472 -- appears to be what GHC has done for a long time, and I suspect it
 473 -- is more useful than line buffering in most cases.
 474
 475 fillReadBufferLoop fd is_line is_stream buf b w size = do
 476   let bytes = size - w
 477   if bytes == 0  -- buffer full?
 478      then return buf{ bufRPtr=0, bufWPtr=w }
 479      else do
 480 #ifdef DEBUG_DUMP
 481   puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
 482 #endif
 483   res <- readRawBuffer "fillReadBuffer" fd is_stream b
 484                        (fromIntegral w) (fromIntegral bytes)
 485   let res' = fromIntegral res
 486 #ifdef DEBUG_DUMP
 487   puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")
 488 #endif
 489   if res' == 0
 490      then if w == 0
 491              then ioe_EOF
 492              else return buf{ bufRPtr=0, bufWPtr=w }
 493      else if res' < bytes && not is_line
 494              then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
 495              else return buf{ bufRPtr=0, bufWPtr=w+res' }
 496
 497
 498 fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
 499 fillReadBufferWithoutBlocking fd is_stream
 500       buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
 501   -- buffer better be empty:
 502   assert (r == 0 && w == 0) $ do
 503 #ifdef DEBUG_DUMP
 504   puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
 505 #endif
 506   res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
 507                        0 (fromIntegral size)
 508   let res' = fromIntegral res
 509 #ifdef DEBUG_DUMP
 510   puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")
 511 #endif
 512   return buf{ bufRPtr=0, bufWPtr=res' }
 513
 514 -- Low level routines for reading/writing to (raw)buffers:
 515
 516 #ifndef mingw32_HOST_OS
 517
 518 {-
 519 NOTE [nonblock]:
 520
 521 Unix has broken semantics when it comes to non-blocking I/O: you can
 522 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
 523 attached to the same underlying file, pipe or TTY; there's no way to
 524 have private non-blocking behaviour for an FD.  See bug #724.
 525
 526 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
 527 come from external sources or are exposed externally are left in
 528 blocking mode.  This solution has some problems though.  We can't
 529 completely simulate a non-blocking read without O_NONBLOCK: several
 530 cases are wrong here.  The cases that are wrong:
 531
 532   * reading/writing to a blocking FD in non-threaded mode.
 533     In threaded mode, we just make a safe call to read().
 534     In non-threaded mode we call select() before attempting to read,
 535     but that leaves a small race window where the data can be read
 536     from the file descriptor before we issue our blocking read().
 537   * readRawBufferNoBlock for a blocking FD
 538
 539 NOTE [2363]:
 540
 541 In the threaded RTS we could just make safe calls to read()/write()
 542 for file descriptors in blocking mode without worrying about blocking
 543 other threads, but the problem with this is that the thread will be
 544 uninterruptible while it is blocked in the foreign call.  See #2363.
 545 So now we always call fdReady() before reading, and if fdReady
 546 indicates that there's no data, we call threadWaitRead.
 547
 548 -}
 549
 550 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 551 readRawBuffer loc fd is_nonblock buf off len
 552   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
 553   | otherwise    = do r <- throwErrnoIfMinus1 loc
 554                                 (unsafe_fdReady (fromIntegral fd) 0 0 0)
 555                       if r /= 0
 556                         then read
 557                         else do threadWaitRead (fromIntegral fd); read
 558   where
 559     do_read call = throwErrnoIfMinus1RetryMayBlock loc call
 560                             (threadWaitRead (fromIntegral fd))
 561     read        = if threaded then safe_read else unsafe_read
 562     unsafe_read = do_read (read_rawBuffer fd buf off len)
 563     safe_read   = do_read (safe_read_rawBuffer fd buf off len)
 564
 565 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 566 readRawBufferPtr loc fd is_nonblock buf off len
 567   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
 568   | otherwise    = do r <- throwErrnoIfMinus1 loc
 569                                 (unsafe_fdReady (fromIntegral fd) 0 0 0)
 570                       if r /= 0
 571                         then read
 572                         else do threadWaitRead (fromIntegral fd); read
 573   where
 574     do_read call = throwErrnoIfMinus1RetryMayBlock loc call
 575                             (threadWaitRead (fromIntegral fd))
 576     read        = if threaded then safe_read else unsafe_read
 577     unsafe_read = do_read (read_off fd buf off len)
 578     safe_read   = do_read (safe_read_off fd buf off len)
 579
 580 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 581 readRawBufferNoBlock loc fd is_nonblock buf off len
 582   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
 583   | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
 584                       if r /= 0 then safe_read
 585                                 else return 0
 586        -- XXX see note [nonblock]
 587  where
 588    do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
 589    unsafe_read  = do_read (read_rawBuffer fd buf off len)
 590    safe_read    = do_read (safe_read_rawBuffer fd buf off len)
 591
 592 readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 593 readRawBufferPtrNoBlock loc fd is_nonblock buf off len
 594   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
 595   | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
 596                       if r /= 0 then safe_read
 597                                 else return 0
 598        -- XXX see note [nonblock]
 599  where
 600    do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
 601    unsafe_read  = do_read (read_off fd buf off len)
 602    safe_read    = do_read (safe_read_off fd buf off len)
 603
 604 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 605 writeRawBuffer loc fd is_nonblock buf off len
 606   | is_nonblock = unsafe_write -- unsafe is ok, it can't block
 607   | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
 608                      if r /= 0
 609                         then write
 610                         else do threadWaitWrite (fromIntegral fd); write
 611   where
 612     do_write call = throwErrnoIfMinus1RetryMayBlock loc call
 613                         (threadWaitWrite (fromIntegral fd))
 614     write        = if threaded then safe_write else unsafe_write
 615     unsafe_write = do_write (write_rawBuffer fd buf off len)
 616     safe_write   = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
 617
 618 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 619 writeRawBufferPtr loc fd is_nonblock buf off len
 620   | is_nonblock = unsafe_write -- unsafe is ok, it can't block
 621   | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
 622                      if r /= 0
 623                         then write
 624                         else do threadWaitWrite (fromIntegral fd); write
 625   where
 626     do_write call = throwErrnoIfMinus1RetryMayBlock loc call
 627                         (threadWaitWrite (fromIntegral fd))
 628     write         = if threaded then safe_write else unsafe_write
 629     unsafe_write  = do_write (write_off fd buf off len)
 630     safe_write    = do_write (safe_write_off (fromIntegral fd) buf off len)
 631
 632 foreign import ccall unsafe "__hscore_PrelHandle_read"
 633    read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 634
 635 foreign import ccall unsafe "__hscore_PrelHandle_read"
 636    read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 637
 638 foreign import ccall unsafe "__hscore_PrelHandle_write"
 639    write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 640
 641 foreign import ccall unsafe "__hscore_PrelHandle_write"
 642    write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 643
 644 foreign import ccall unsafe "fdReady"
 645   unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 646
 647 #else /* mingw32_HOST_OS.... */
 648
 649 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 650 readRawBuffer loc fd is_stream buf off len
 651   | threaded  = blockingReadRawBuffer loc fd is_stream buf off len
 652   | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
 653
 654 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 655 readRawBufferPtr loc fd is_stream buf off len
 656   | threaded  = blockingReadRawBufferPtr loc fd is_stream buf off len
 657   | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
 658
 659 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 660 writeRawBuffer loc fd is_stream buf off len
 661   | threaded =  blockingWriteRawBuffer loc fd is_stream buf off len
 662   | otherwise = asyncWriteRawBuffer    loc fd is_stream buf off len
 663
 664 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 665 writeRawBufferPtr loc fd is_stream buf off len
 666   | threaded  = blockingWriteRawBufferPtr loc fd is_stream buf off len
 667   | otherwise = asyncWriteRawBufferPtr    loc fd is_stream buf off len
 668
 669 -- ToDo: we don't have a non-blocking primitve read on Win32
 670 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 671 readRawBufferNoBlock = readRawBuffer
 672
 673 readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 674 readRawBufferPtrNoBlock = readRawBufferPtr
 675 -- Async versions of the read/write primitives, for the non-threaded RTS
 676
 677 asyncReadRawBuffer loc fd is_stream buf off len = do
 678     (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
 679                  (fromIntegral len) off buf
 680     if l == (-1)
 681       then
 682         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 683       else return (fromIntegral l)
 684
 685 asyncReadRawBufferPtr loc fd is_stream buf off len = do
 686     (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
 687                         (fromIntegral len) (buf `plusPtr` off)
 688     if l == (-1)
 689       then
 690         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 691       else return (fromIntegral l)
 692
 693 asyncWriteRawBuffer loc fd is_stream buf off len = do
 694     (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
 695                         (fromIntegral len) off buf
 696     if l == (-1)
 697       then
 698         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 699       else return (fromIntegral l)
 700
 701 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
 702     (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
 703                   (fromIntegral len) (buf `plusPtr` off)
 704     if l == (-1)
 705       then
 706         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 707       else return (fromIntegral l)
 708
 709 -- Blocking versions of the read/write primitives, for the threaded RTS
 710
 711 blockingReadRawBuffer loc fd True buf off len =
 712   throwErrnoIfMinus1Retry loc $
 713     safe_recv_rawBuffer fd buf off len
 714 blockingReadRawBuffer loc fd False buf off len =
 715   throwErrnoIfMinus1Retry loc $
 716     safe_read_rawBuffer fd buf off len
 717
 718 blockingReadRawBufferPtr loc fd True buf off len =
 719   throwErrnoIfMinus1Retry loc $
 720     safe_recv_off fd buf off len
 721 blockingReadRawBufferPtr loc fd False buf off len =
 722   throwErrnoIfMinus1Retry loc $
 723     safe_read_off fd buf off len
 724
 725 blockingWriteRawBuffer loc fd True buf off len =
 726   throwErrnoIfMinus1Retry loc $
 727     safe_send_rawBuffer fd buf off len
 728 blockingWriteRawBuffer loc fd False buf off len =
 729   throwErrnoIfMinus1Retry loc $
 730     safe_write_rawBuffer fd buf off len
 731
 732 blockingWriteRawBufferPtr loc fd True buf off len =
 733   throwErrnoIfMinus1Retry loc $
 734     safe_send_off fd buf off len
 735 blockingWriteRawBufferPtr loc fd False buf off len =
 736   throwErrnoIfMinus1Retry loc $
 737     safe_write_off fd buf off len
 738
 739 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 740 -- These calls may block, but that's ok.
 741
 742 foreign import ccall safe "__hscore_PrelHandle_recv"
 743    safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 744
 745 foreign import ccall safe "__hscore_PrelHandle_recv"
 746    safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 747
 748 foreign import ccall safe "__hscore_PrelHandle_send"
 749    safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 750
 751 foreign import ccall safe "__hscore_PrelHandle_send"
 752    safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 753
 754 #endif
 755
 756 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 757
 758 foreign import ccall safe "__hscore_PrelHandle_read"
 759    safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
 760
 761 foreign import ccall safe "__hscore_PrelHandle_read"
 762    safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
 763
 764 foreign import ccall safe "__hscore_PrelHandle_write"
 765    safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 766
 767 foreign import ccall safe "__hscore_PrelHandle_write"
 768    safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 769
 770 -- ---------------------------------------------------------------------------
 771 -- Standard Handles
 772
 773 -- Three handles are allocated during program initialisation.  The first
 774 -- two manage input or output from the Haskell program's standard input
 775 -- or output channel respectively.  The third manages output to the
 776 -- standard error channel. These handles are initially open.
 777
 778 fd_stdin  = 0 :: FD
 779 fd_stdout = 1 :: FD
 780 fd_stderr = 2 :: FD
 781
 782 -- | A handle managing input from the Haskell program's standard input channel.
 783 stdin :: Handle
 784 stdin = unsafePerformIO $ do
 785    -- ToDo: acquire lock
 786    -- We don't set non-blocking mode on standard handles, because it may
 787    -- confuse other applications attached to the same TTY/pipe
 788    -- see Note [nonblock]
 789    (buf, bmode) <- getBuffer fd_stdin ReadBuffer
 790    mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
 791
 792 -- | A handle managing output to the Haskell program's standard output channel.
 793 stdout :: Handle
 794 stdout = unsafePerformIO $ do
 795    -- ToDo: acquire lock
 796    -- We don't set non-blocking mode on standard handles, because it may
 797    -- confuse other applications attached to the same TTY/pipe
 798    -- see Note [nonblock]
 799    (buf, bmode) <- getBuffer fd_stdout WriteBuffer
 800    mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
 801
 802 -- | A handle managing output to the Haskell program's standard error channel.
 803 stderr :: Handle
 804 stderr = unsafePerformIO $ do
 805     -- ToDo: acquire lock
 806    -- We don't set non-blocking mode on standard handles, because it may
 807    -- confuse other applications attached to the same TTY/pipe
 808    -- see Note [nonblock]
 809    buf <- mkUnBuffer
 810    mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
 811
 812 -- ---------------------------------------------------------------------------
 813 -- Opening and Closing Files
 814
 815 addFilePathToIOError fun fp (IOError h iot _ str _)
 816   = IOError h iot fun str (Just fp)
 817
 818 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
 819 -- handle to manage the file @file@.  It manages input if @mode@
 820 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
 821 -- and both input and output if mode is 'ReadWriteMode'.
 822 --
 823 -- If the file does not exist and it is opened for output, it should be
 824 -- created as a new file.  If @mode@ is 'WriteMode' and the file
 825 -- already exists, then it should be truncated to zero length.
 826 -- Some operating systems delete empty files, so there is no guarantee
 827 -- that the file will exist following an 'openFile' with @mode@
 828 -- 'WriteMode' unless it is subsequently written to successfully.
 829 -- The handle is positioned at the end of the file if @mode@ is
 830 -- 'AppendMode', and otherwise at the beginning (in which case its
 831 -- internal position is 0).
 832 -- The initial buffer mode is implementation-dependent.
 833 --
 834 -- This operation may fail with:
 835 --
 836 --  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
 837 --
 838 --  * 'isDoesNotExistError' if the file does not exist; or
 839 --
 840 --  * 'isPermissionError' if the user does not have permission to open the file.
 841 --
 842 -- Note: if you will be working with files containing binary data, you'll want to
 843 -- be using 'openBinaryFile'.
 844 openFile :: FilePath -> IOMode -> IO Handle
 845 openFile fp im =
 846   catch
 847     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
 848     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 849
 850 -- | Like 'openFile', but open the file in binary mode.
 851 -- On Windows, reading a file in text mode (which is the default)
 852 -- will translate CRLF to LF, and writing will translate LF to CRLF.
 853 -- This is usually what you want with text files.  With binary files
 854 -- this is undesirable; also, as usual under Microsoft operating systems,
 855 -- text mode treats control-Z as EOF.  Binary mode turns off all special
 856 -- treatment of end-of-line and end-of-file characters.
 857 -- (See also 'hSetBinaryMode'.)
 858
 859 openBinaryFile :: FilePath -> IOMode -> IO Handle
 860 openBinaryFile fp m =
 861   catch
 862     (openFile' fp m True)
 863     (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
 864
 865 openFile' filepath mode binary =
 866   withCString filepath $ \ f ->
 867
 868     let
 869       oflags1 = case mode of
 870                   ReadMode      -> read_flags
 871 #ifdef mingw32_HOST_OS
 872                   WriteMode     -> write_flags .|. o_TRUNC
 873 #else
 874                   WriteMode     -> write_flags
 875 #endif
 876                   ReadWriteMode -> rw_flags
 877                   AppendMode    -> append_flags
 878
 879       binary_flags
 880           | binary    = o_BINARY
 881           | otherwise = 0
 882
 883       oflags = oflags1 .|. binary_flags
 884     in do
 885
 886     -- the old implementation had a complicated series of three opens,
 887     -- which is perhaps because we have to be careful not to open
 888     -- directories.  However, the man pages I've read say that open()
 889     -- always returns EISDIR if the file is a directory and was opened
 890     -- for writing, so I think we're ok with a single open() here...
 891     fd <- throwErrnoIfMinus1Retry "openFile"
 892                 (c_open f (fromIntegral oflags) 0o666)
 893
 894     stat@(fd_type,_,_) <- fdStat fd
 895
 896     h <- fdToHandle_stat fd (Just stat) False filepath mode binary
 897             `catchAny` \e -> do c_close fd; throw e
 898         -- NB. don't forget to close the FD if fdToHandle' fails, otherwise
 899         -- this FD leaks.
 900         -- ASSERT: if we just created the file, then fdToHandle' won't fail
 901         -- (so we don't need to worry about removing the newly created file
 902         --  in the event of an error).
 903
 904 #ifndef mingw32_HOST_OS
 905         -- we want to truncate() if this is an open in WriteMode, but only
 906         -- if the target is a RegularFile.  ftruncate() fails on special files
 907         -- like /dev/null.
 908     if mode == WriteMode && fd_type == RegularFile
 909       then throwErrnoIf (/=0) "openFile"
 910               (c_ftruncate fd 0)
 911       else return 0
 912 #endif
 913     return h
 914
 915
 916 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 917 output_flags = std_flags    .|. o_CREAT
 918 read_flags   = std_flags    .|. o_RDONLY
 919 write_flags  = output_flags .|. o_WRONLY
 920 rw_flags     = output_flags .|. o_RDWR
 921 append_flags = write_flags  .|. o_APPEND
 922
 923 -- ---------------------------------------------------------------------------
 924 -- fdToHandle
 925
 926 fdToHandle_stat :: FD
 927             -> Maybe (FDType, CDev, CIno)
 928             -> Bool
 929             -> FilePath
 930             -> IOMode
 931             -> Bool
 932             -> IO Handle
 933
 934 fdToHandle_stat fd mb_stat is_socket filepath mode binary = do
 935
 936 #ifdef mingw32_HOST_OS
 937     -- On Windows, the is_socket flag indicates that the Handle is a socket
 938 #else
 939     -- On Unix, the is_socket flag indicates that the FD can be made non-blocking
 940     let non_blocking = is_socket
 941
 942     when non_blocking $ setNonBlockingFD fd
 943     -- turn on non-blocking mode
 944 #endif
 945
 946     let (ha_type, write) =
 947           case mode of
 948             ReadMode      -> ( ReadHandle,      False )
 949             WriteMode     -> ( WriteHandle,     True )
 950             ReadWriteMode -> ( ReadWriteHandle, True )
 951             AppendMode    -> ( AppendHandle,    True )
 952
 953     -- open() won't tell us if it was a directory if we only opened for
 954     -- reading, so check again.
 955     (fd_type,dev,ino) <-
 956       case mb_stat of
 957         Just x  -> return x
 958         Nothing -> fdStat fd
 959
 960     case fd_type of
 961         Directory ->
 962            ioException (IOError Nothing InappropriateType "openFile"
 963                            "is a directory" Nothing)
 964
 965         -- regular files need to be locked
 966         RegularFile -> do
 967 #ifndef mingw32_HOST_OS
 968            -- On Windows we use explicit exclusion via sopen() to implement
 969            -- this locking (see __hscore_open()); on Unix we have to
 970            -- implment it in the RTS.
 971            r <- lockFile fd dev ino (fromBool write)
 972            when (r == -1)  $
 973                 ioException (IOError Nothing ResourceBusy "openFile"
 974                                    "file is locked" Nothing)
 975 #endif
 976            mkFileHandle fd is_socket filepath ha_type binary
 977
 978         Stream
 979            -- only *Streams* can be DuplexHandles.  Other read/write
 980            -- Handles must share a buffer.
 981            | ReadWriteHandle <- ha_type ->
 982                 mkDuplexHandle fd is_socket filepath binary
 983            | otherwise ->
 984                 mkFileHandle   fd is_socket filepath ha_type binary
 985
 986         RawDevice ->
 987                 mkFileHandle fd is_socket filepath ha_type binary
 988
 989 -- | Old API kept to avoid breaking clients
 990 fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool
 991             -> IO Handle
 992 fdToHandle' fd mb_type is_socket filepath mode binary
 993  = do
 994        let mb_stat = case mb_type of
 995                         Nothing          -> Nothing
 996                           -- fdToHandle_stat will do the stat:
 997                         Just RegularFile -> Nothing
 998                           -- no stat required for streams etc.:
 999                         Just other       -> Just (other,0,0)
1000        fdToHandle_stat fd mb_stat is_socket filepath mode binary
1001
1002 fdToHandle :: FD -> IO Handle
1003 fdToHandle fd = do
1004    mode <- fdGetMode fd
1005    let fd_str = "<file descriptor: " ++ show fd ++ ">"
1006    fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-}
1007         -- NB. the is_socket flag is False, meaning that:
1008         --  on Unix the file descriptor will *not* be put in non-blocking mode
1009         --  on Windows we're guessing this is not a socket (XXX)
1010
1011 #ifndef mingw32_HOST_OS
1012 foreign import ccall unsafe "lockFile"
1013   lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
1014
1015 foreign import ccall unsafe "unlockFile"
1016   unlockFile :: CInt -> IO CInt
1017 #endif
1018
1019 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
1020         -> IO Handle
1021 mkStdHandle fd filepath ha_type buf bmode = do
1022    spares <- newIORef BufferListNil
1023    newFileHandle filepath (stdHandleFinalizer filepath)
1024             (Handle__ { haFD = fd,
1025                         haType = ha_type,
1026                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
1027                         haIsStream = False, -- means FD is blocking on Unix
1028                         haBufferMode = bmode,
1029                         haBuffer = buf,
1030                         haBuffers = spares,
1031                         haOtherSide = Nothing
1032                       })
1033
1034 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
1035 mkFileHandle fd is_stream filepath ha_type binary = do
1036   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
1037
1038 #ifdef mingw32_HOST_OS
1039   -- On Windows, if this is a read/write handle and we are in text mode,
1040   -- turn off buffering.  We don't correctly handle the case of switching
1041   -- from read mode to write mode on a buffered text-mode handle, see bug
1042   -- \#679.
1043   bmode <- case ha_type of
1044                 ReadWriteHandle | not binary -> return NoBuffering
1045                 _other                       -> return bmode
1046 #endif
1047
1048   spares <- newIORef BufferListNil
1049   newFileHandle filepath (handleFinalizer filepath)
1050             (Handle__ { haFD = fd,
1051                         haType = ha_type,
1052                         haIsBin = binary,
1053                         haIsStream = is_stream,
1054                         haBufferMode = bmode,
1055                         haBuffer = buf,
1056                         haBuffers = spares,
1057                         haOtherSide = Nothing
1058                       })
1059
1060 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
1061 mkDuplexHandle fd is_stream filepath binary = do
1062   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
1063   w_spares <- newIORef BufferListNil
1064   let w_handle_ =
1065              Handle__ { haFD = fd,
1066                         haType = WriteHandle,
1067                         haIsBin = binary,
1068                         haIsStream = is_stream,
1069                         haBufferMode = w_bmode,
1070                         haBuffer = w_buf,
1071                         haBuffers = w_spares,
1072                         haOtherSide = Nothing
1073                       }
1074   write_side <- newMVar w_handle_
1075
1076   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
1077   r_spares <- newIORef BufferListNil
1078   let r_handle_ =
1079              Handle__ { haFD = fd,
1080                         haType = ReadHandle,
1081                         haIsBin = binary,
1082                         haIsStream = is_stream,
1083                         haBufferMode = r_bmode,
1084                         haBuffer = r_buf,
1085                         haBuffers = r_spares,
1086                         haOtherSide = Just write_side
1087                       }
1088   read_side <- newMVar r_handle_
1089
1090   addMVarFinalizer write_side (handleFinalizer filepath write_side)
1091   return (DuplexHandle filepath read_side write_side)
1092
1093
1094 initBufferState ReadHandle = ReadBuffer
1095 initBufferState _          = WriteBuffer
1096
1097 -- ---------------------------------------------------------------------------
1098 -- Closing a handle
1099
1100 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
1101 -- computation finishes, if @hdl@ is writable its buffer is flushed as
1102 -- for 'hFlush'.
1103 -- Performing 'hClose' on a handle that has already been closed has no effect;
1104 -- doing so is not an error.  All other operations on a closed handle will fail.
1105 -- If 'hClose' fails for any reason, any further operations (apart from
1106 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
1107 -- closed.
1108
1109 hClose :: Handle -> IO ()
1110 hClose h@(FileHandle _ m)     = do
1111   mb_exc <- hClose' h m
1112   case mb_exc of
1113     Nothing -> return ()
1114     Just e  -> throwIO e
1115 hClose h@(DuplexHandle _ r w) = do
1116   mb_exc1 <- hClose' h w
1117   mb_exc2 <- hClose' h r
1118   case (do mb_exc1; mb_exc2) of
1119      Nothing -> return ()
1120      Just e  -> throwIO e
1121
1122 hClose' h m = withHandle' "hClose" h m $ hClose_help
1123
1124 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
1125 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
1126 -- then closed immediately.  We have to be careful with DuplexHandles
1127 -- though: we have to leave the closing to the finalizer in that case,
1128 -- because the write side may still be in use.
1129 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
1130 hClose_help handle_ =
1131   case haType handle_ of
1132       ClosedHandle -> return (handle_,Nothing)
1133       _ -> do flushWriteBufferOnly handle_ -- interruptible
1134               hClose_handle_ handle_
1135
1136 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
1137 hClose_handle_ handle_ = do
1138     let fd = haFD handle_
1139
1140     -- close the file descriptor, but not when this is the read
1141     -- side of a duplex handle.
1142     -- If an exception is raised by the close(), we want to continue
1143     -- to close the handle and release the lock if it has one, then
1144     -- we return the exception to the caller of hClose_help which can
1145     -- raise it if necessary.
1146     maybe_exception <-
1147       case haOtherSide handle_ of
1148         Nothing -> (do
1149                       throwErrnoIfMinus1Retry_ "hClose"
1150 #ifdef mingw32_HOST_OS
1151                                 (closeFd (haIsStream handle_) fd)
1152 #else
1153                                 (c_close fd)
1154 #endif
1155                       return Nothing
1156                     )
1157                      `catchException` \e -> return (Just e)
1158
1159         Just _  -> return Nothing
1160
1161     -- free the spare buffers
1162     writeIORef (haBuffers handle_) BufferListNil
1163     writeIORef (haBuffer  handle_) noBuffer
1164
1165 #ifndef mingw32_HOST_OS
1166     -- unlock it
1167     unlockFile fd
1168 #endif
1169
1170     -- we must set the fd to -1, because the finalizer is going
1171     -- to run eventually and try to close/unlock it.
1172     return (handle_{ haFD        = -1,
1173                      haType      = ClosedHandle
1174                    },
1175             maybe_exception)
1176
1177 {-# NOINLINE noBuffer #-}
1178 noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
1179
1180 -----------------------------------------------------------------------------
1181 -- Detecting and changing the size of a file
1182
1183 -- | For a handle @hdl@ which attached to a physical file,
1184 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1185
1186 hFileSize :: Handle -> IO Integer
1187 hFileSize handle =
1188     withHandle_ "hFileSize" handle $ \ handle_ -> do
1189     case haType handle_ of
1190       ClosedHandle              -> ioe_closedHandle
1191       SemiClosedHandle          -> ioe_closedHandle
1192       _ -> do flushWriteBufferOnly handle_
1193               r <- fdFileSize (haFD handle_)
1194               if r /= -1
1195                  then return r
1196                  else ioException (IOError Nothing InappropriateType "hFileSize"
1197                                    "not a regular file" Nothing)
1198
1199
1200 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1201
1202 hSetFileSize :: Handle -> Integer -> IO ()
1203 hSetFileSize handle size =
1204     withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1205     case haType handle_ of
1206       ClosedHandle              -> ioe_closedHandle
1207       SemiClosedHandle          -> ioe_closedHandle
1208       _ -> do flushWriteBufferOnly handle_
1209               throwErrnoIf (/=0) "hSetFileSize"
1210                  (c_ftruncate (haFD handle_) (fromIntegral size))
1211               return ()
1212
1213 -- ---------------------------------------------------------------------------
1214 -- Detecting the End of Input
1215
1216 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1217 -- 'True' if no further input can be taken from @hdl@ or for a
1218 -- physical file, if the current I\/O position is equal to the length of
1219 -- the file.  Otherwise, it returns 'False'.
1220 --
1221 -- NOTE: 'hIsEOF' may block, because it is the same as calling
1222 -- 'hLookAhead' and checking for an EOF exception.
1223
1224 hIsEOF :: Handle -> IO Bool
1225 hIsEOF handle =
1226   catch
1227      (do hLookAhead handle; return False)
1228      (\e -> if isEOFError e then return True else ioError e)
1229
1230 -- | The computation 'isEOF' is identical to 'hIsEOF',
1231 -- except that it works only on 'stdin'.
1232
1233 isEOF :: IO Bool
1234 isEOF = hIsEOF stdin
1235
1236 -- ---------------------------------------------------------------------------
1237 -- Looking ahead
1238
1239 -- | Computation 'hLookAhead' returns the next character from the handle
1240 -- without removing it from the input buffer, blocking until a character
1241 -- is available.
1242 --
1243 -- This operation may fail with:
1244 --
1245 --  * 'isEOFError' if the end of file has been reached.
1246
1247 hLookAhead :: Handle -> IO Char
1248 hLookAhead handle = do
1249   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
1250   let ref     = haBuffer handle_
1251       fd      = haFD handle_
1252       is_line = haBufferMode handle_ == LineBuffering
1253   buf <- readIORef ref
1254
1255   -- fill up the read buffer if necessary
1256   new_buf <- if bufferEmpty buf
1257                 then fillReadBuffer fd True (haIsStream handle_) buf
1258                 else return buf
1259
1260   writeIORef ref new_buf
1261
1262   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1263   return c
1264
1265 -- ---------------------------------------------------------------------------
1266 -- Buffering Operations
1267
1268 -- Three kinds of buffering are supported: line-buffering,
1269 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
1270 -- further explanation of what the type represent.
1271
1272 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1273 -- handle @hdl@ on subsequent reads and writes.
1274 --
1275 -- If the buffer mode is changed from 'BlockBuffering' or
1276 -- 'LineBuffering' to 'NoBuffering', then
1277 --
1278 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1279 --
1280 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
1281 --
1282 -- This operation may fail with:
1283 --
1284 --  * 'isPermissionError' if the handle has already been used for reading
1285 --    or writing and the implementation does not allow the buffering mode
1286 --    to be changed.
1287
1288 hSetBuffering :: Handle -> BufferMode -> IO ()
1289 hSetBuffering handle mode =
1290   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1291   case haType handle_ of
1292     ClosedHandle -> ioe_closedHandle
1293     _ -> do
1294          {- Note:
1295             - we flush the old buffer regardless of whether
1296               the new buffer could fit the contents of the old buffer
1297               or not.
1298             - allow a handle's buffering to change even if IO has
1299               occurred (ANSI C spec. does not allow this, nor did
1300               the previous implementation of IO.hSetBuffering).
1301             - a non-standard extension is to allow the buffering
1302               of semi-closed handles to change [sof 6/98]
1303           -}
1304           flushBuffer handle_
1305
1306           let state = initBufferState (haType handle_)
1307           new_buf <-
1308             case mode of
1309                 -- we always have a 1-character read buffer for
1310                 -- unbuffered  handles: it's needed to
1311                 -- support hLookAhead.
1312               NoBuffering            -> allocateBuffer 1 ReadBuffer
1313               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1314               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1315               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1316                                       | otherwise -> allocateBuffer n state
1317           writeIORef (haBuffer handle_) new_buf
1318
1319           -- for input terminals we need to put the terminal into
1320           -- cooked or raw mode depending on the type of buffering.
1321           is_tty <- fdIsTTY (haFD handle_)
1322           when (is_tty && isReadableHandleType (haType handle_)) $
1323                 case mode of
1324 #ifndef mingw32_HOST_OS
1325         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1326         -- for most common uses), so simply disable its use here.
1327                   NoBuffering -> setCooked (haFD handle_) False
1328 #else
1329                   NoBuffering -> return ()
1330 #endif
1331                   _           -> setCooked (haFD handle_) True
1332
1333           -- throw away spare buffers, they might be the wrong size
1334           writeIORef (haBuffers handle_) BufferListNil
1335
1336           return (handle_{ haBufferMode = mode })
1337
1338 -- -----------------------------------------------------------------------------
1339 -- hFlush
1340
1341 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1342 -- in handle @hdl@ to be sent immediately to the operating system.
1343 --
1344 -- This operation may fail with:
1345 --
1346 --  * 'isFullError' if the device is full;
1347 --
1348 --  * 'isPermissionError' if a system resource limit would be exceeded.
1349 --    It is unspecified whether the characters in the buffer are discarded
1350 --    or retained under these circumstances.
1351
1352 hFlush :: Handle -> IO ()
1353 hFlush handle =
1354    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1355    buf <- readIORef (haBuffer handle_)
1356    if bufferIsWritable buf && not (bufferEmpty buf)
1357         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1358                 writeIORef (haBuffer handle_) flushed_buf
1359         else return ()
1360
1361
1362 -- -----------------------------------------------------------------------------
1363 -- Repositioning Handles
1364
1365 data HandlePosn = HandlePosn Handle HandlePosition
1366
1367 instance Eq HandlePosn where
1368     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1369
1370 instance Show HandlePosn where
1371    showsPrec p (HandlePosn h pos) =
1372         showsPrec p h . showString " at position " . shows pos
1373
1374   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1375   -- We represent it as an Integer on the Haskell side, but
1376   -- cheat slightly in that hGetPosn calls upon a C helper
1377   -- that reports the position back via (merely) an Int.
1378 type HandlePosition = Integer
1379
1380 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1381 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1382
1383 hGetPosn :: Handle -> IO HandlePosn
1384 hGetPosn handle = do
1385     posn <- hTell handle
1386     return (HandlePosn handle posn)
1387
1388 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1389 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1390 -- to the position it held at the time of the call to 'hGetPosn'.
1391 --
1392 -- This operation may fail with:
1393 --
1394 --  * 'isPermissionError' if a system resource limit would be exceeded.
1395
1396 hSetPosn :: HandlePosn -> IO ()
1397 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1398
1399 -- ---------------------------------------------------------------------------
1400 -- hSeek
1401
1402 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1403 data SeekMode
1404   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1405   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1406                         -- from the current position.
1407   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1408                         -- from the end of the file.
1409     deriving (Eq, Ord, Ix, Enum, Read, Show)
1410
1411 {- Note:
1412  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1413    seeking at or past EOF.
1414
1415  - we possibly deviate from the report on the issue of seeking within
1416    the buffer and whether to flush it or not.  The report isn't exactly
1417    clear here.
1418 -}
1419
1420 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1421 -- @hdl@ depending on @mode@.
1422 -- The offset @i@ is given in terms of 8-bit bytes.
1423 --
1424 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1425 -- in the current buffer will first cause any items in the output buffer to be
1426 -- written to the device, and then cause the input buffer to be discarded.
1427 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1428 -- subset of the possible positioning operations (for instance, it may only
1429 -- be possible to seek to the end of a tape, or to a positive offset from
1430 -- the beginning or current position).
1431 -- It is not possible to set a negative I\/O position, or for
1432 -- a physical file, an I\/O position beyond the current end-of-file.
1433 --
1434 -- This operation may fail with:
1435 --
1436 --  * 'isPermissionError' if a system resource limit would be exceeded.
1437
1438 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1439 hSeek handle mode offset =
1440     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1441 #   ifdef DEBUG_DUMP
1442     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1443 #   endif
1444     let ref = haBuffer handle_
1445     buf <- readIORef ref
1446     let r = bufRPtr buf
1447         w = bufWPtr buf
1448         fd = haFD handle_
1449
1450     let do_seek =
1451           throwErrnoIfMinus1Retry_ "hSeek"
1452             (c_lseek (haFD handle_) (fromIntegral offset) whence)
1453
1454         whence :: CInt
1455         whence = case mode of
1456                    AbsoluteSeek -> sEEK_SET
1457                    RelativeSeek -> sEEK_CUR
1458                    SeekFromEnd  -> sEEK_END
1459
1460     if bufferIsWritable buf
1461         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1462                 writeIORef ref new_buf
1463                 do_seek
1464         else do
1465
1466     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1467         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1468         else do
1469
1470     new_buf <- flushReadBuffer (haFD handle_) buf
1471     writeIORef ref new_buf
1472     do_seek
1473
1474
1475 hTell :: Handle -> IO Integer
1476 hTell handle =
1477     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1478
1479 #if defined(mingw32_HOST_OS)
1480         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1481         -- so we can't easily calculate the file position using the
1482         -- current buffer size.  Just flush instead.
1483       flushBuffer handle_
1484 #endif
1485       let fd = haFD handle_
1486       posn <- fromIntegral `liftM`
1487                 throwErrnoIfMinus1Retry "hGetPosn"
1488                    (c_lseek fd 0 sEEK_CUR)
1489
1490       let ref = haBuffer handle_
1491       buf <- readIORef ref
1492
1493       let real_posn
1494            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1495            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1496 #     ifdef DEBUG_DUMP
1497       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1498       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1499 #     endif
1500       return real_posn
1501
1502 -- -----------------------------------------------------------------------------
1503 -- Handle Properties
1504
1505 -- A number of operations return information about the properties of a
1506 -- handle.  Each of these operations returns `True' if the handle has
1507 -- the specified property, and `False' otherwise.
1508
1509 hIsOpen :: Handle -> IO Bool
1510 hIsOpen handle =
1511     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1512     case haType handle_ of
1513       ClosedHandle         -> return False
1514       SemiClosedHandle     -> return False
1515       _                    -> return True
1516
1517 hIsClosed :: Handle -> IO Bool
1518 hIsClosed handle =
1519     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1520     case haType handle_ of
1521       ClosedHandle         -> return True
1522       _                    -> return False
1523
1524 {- not defined, nor exported, but mentioned
1525    here for documentation purposes:
1526
1527     hSemiClosed :: Handle -> IO Bool
1528     hSemiClosed h = do
1529        ho <- hIsOpen h
1530        hc <- hIsClosed h
1531        return (not (ho || hc))
1532 -}
1533
1534 hIsReadable :: Handle -> IO Bool
1535 hIsReadable (DuplexHandle _ _ _) = return True
1536 hIsReadable handle =
1537     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1538     case haType handle_ of
1539       ClosedHandle         -> ioe_closedHandle
1540       SemiClosedHandle     -> ioe_closedHandle
1541       htype                -> return (isReadableHandleType htype)
1542
1543 hIsWritable :: Handle -> IO Bool
1544 hIsWritable (DuplexHandle _ _ _) = return True
1545 hIsWritable handle =
1546     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1547     case haType handle_ of
1548       ClosedHandle         -> ioe_closedHandle
1549       SemiClosedHandle     -> ioe_closedHandle
1550       htype                -> return (isWritableHandleType htype)
1551
1552 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1553 -- for @hdl@.
1554
1555 hGetBuffering :: Handle -> IO BufferMode
1556 hGetBuffering handle =
1557     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1558     case haType handle_ of
1559       ClosedHandle         -> ioe_closedHandle
1560       _ ->
1561            -- We're being non-standard here, and allow the buffering
1562            -- of a semi-closed handle to be queried.   -- sof 6/98
1563           return (haBufferMode handle_)  -- could be stricter..
1564
1565 hIsSeekable :: Handle -> IO Bool
1566 hIsSeekable handle =
1567     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1568     case haType handle_ of
1569       ClosedHandle         -> ioe_closedHandle
1570       SemiClosedHandle     -> ioe_closedHandle
1571       AppendHandle         -> return False
1572       _                    -> do t <- fdType (haFD handle_)
1573                                  return ((t == RegularFile    || t == RawDevice)
1574                                          && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))
1575
1576 -- -----------------------------------------------------------------------------
1577 -- Changing echo status (Non-standard GHC extensions)
1578
1579 -- | Set the echoing status of a handle connected to a terminal.
1580
1581 hSetEcho :: Handle -> Bool -> IO ()
1582 hSetEcho handle on = do
1583     isT   <- hIsTerminalDevice handle
1584     if not isT
1585      then return ()
1586      else
1587       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1588       case haType handle_ of
1589          ClosedHandle -> ioe_closedHandle
1590          _            -> setEcho (haFD handle_) on
1591
1592 -- | Get the echoing status of a handle connected to a terminal.
1593
1594 hGetEcho :: Handle -> IO Bool
1595 hGetEcho handle = do
1596     isT   <- hIsTerminalDevice handle
1597     if not isT
1598      then return False
1599      else
1600        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1601        case haType handle_ of
1602          ClosedHandle -> ioe_closedHandle
1603          _            -> getEcho (haFD handle_)
1604
1605 -- | Is the handle connected to a terminal?
1606
1607 hIsTerminalDevice :: Handle -> IO Bool
1608 hIsTerminalDevice handle = do
1609     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1610      case haType handle_ of
1611        ClosedHandle -> ioe_closedHandle
1612        _            -> fdIsTTY (haFD handle_)
1613
1614 -- -----------------------------------------------------------------------------
1615 -- hSetBinaryMode
1616
1617 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1618 -- (See also 'openBinaryFile'.)
1619
1620 hSetBinaryMode :: Handle -> Bool -> IO ()
1621 hSetBinaryMode handle bin =
1622   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1623     do throwErrnoIfMinus1_ "hSetBinaryMode"
1624           (setmode (haFD handle_) bin)
1625        return handle_{haIsBin=bin}
1626
1627 foreign import ccall unsafe "__hscore_setmode"
1628   setmode :: CInt -> Bool -> IO CInt
1629
1630 -- -----------------------------------------------------------------------------
1631 -- Duplicating a Handle
1632
1633 -- | Returns a duplicate of the original handle, with its own buffer.
1634 -- The two Handles will share a file pointer, however.  The original
1635 -- handle's buffer is flushed, including discarding any input data,
1636 -- before the handle is duplicated.
1637
1638 hDuplicate :: Handle -> IO Handle
1639 hDuplicate h@(FileHandle path m) = do
1640   new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
1641   newFileHandle path (handleFinalizer path) new_h_
1642 hDuplicate h@(DuplexHandle path r w) = do
1643   new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
1644   new_w <- newMVar new_w_
1645   new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
1646   new_r <- newMVar new_r_
1647   addMVarFinalizer new_w (handleFinalizer path new_w)
1648   return (DuplexHandle path new_r new_w)
1649
1650 dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
1651           -> IO (Handle__, Handle__)
1652 dupHandle h other_side h_ = do
1653   -- flush the buffer first, so we don't have to copy its contents
1654   flushBuffer h_
1655   new_fd <- case other_side of
1656                 Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
1657                 Just r -> withHandle_' "dupHandle" h r (return . haFD)
1658   dupHandle_ other_side h_ new_fd
1659
1660 dupHandleTo other_side hto_ h_ = do
1661   flushBuffer h_
1662   -- Windows' dup2 does not return the new descriptor, unlike Unix
1663   throwErrnoIfMinus1 "dupHandleTo" $
1664         c_dup2 (haFD h_) (haFD hto_)
1665   dupHandle_ other_side h_ (haFD hto_)
1666
1667 dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
1668            -> IO (Handle__, Handle__)
1669 dupHandle_ other_side h_ new_fd = do
1670   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1671   ioref <- newIORef buffer
1672   ioref_buffers <- newIORef BufferListNil
1673
1674   let new_handle_ = h_{ haFD = new_fd,
1675                         haBuffer = ioref,
1676                         haBuffers = ioref_buffers,
1677                         haOtherSide = other_side }
1678   return (h_, new_handle_)
1679
1680 -- -----------------------------------------------------------------------------
1681 -- Replacing a Handle
1682
1683 {- |
1684 Makes the second handle a duplicate of the first handle.  The second
1685 handle will be closed first, if it is not already.
1686
1687 This can be used to retarget the standard Handles, for example:
1688
1689 > do h <- openFile "mystdout" WriteMode
1690 >    hDuplicateTo h stdout
1691 -}
1692
1693 hDuplicateTo :: Handle -> Handle -> IO ()
1694 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1695  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1696    _ <- hClose_help h2_
1697    withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
1698 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1699  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1700    _ <- hClose_help w2_
1701    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
1702  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1703    _ <- hClose_help r2_
1704    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
1705 hDuplicateTo h1 _ =
1706    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1707                 "handles are incompatible" Nothing)
1708
1709 -- ---------------------------------------------------------------------------
1710 -- showing Handles.
1711 --
1712 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1713 -- than the (pure) instance of 'Show' for 'Handle'.
1714
1715 hShow :: Handle -> IO String
1716 hShow h@(FileHandle path _) = showHandle' path False h
1717 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1718
1719 showHandle' filepath is_duplex h =
1720   withHandle_ "showHandle" h $ \hdl_ ->
1721     let
1722      showType | is_duplex = showString "duplex (read-write)"
1723               | otherwise = shows (haType hdl_)
1724     in
1725     return
1726       (( showChar '{' .
1727         showHdl (haType hdl_)
1728             (showString "loc=" . showString filepath . showChar ',' .
1729              showString "type=" . showType . showChar ',' .
1730              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1731              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1732       ) "")
1733    where
1734
1735     showHdl :: HandleType -> ShowS -> ShowS
1736     showHdl ht cont =
1737        case ht of
1738         ClosedHandle  -> shows ht . showString "}"
1739         _ -> cont
1740
1741     showBufMode :: Buffer -> BufferMode -> ShowS
1742     showBufMode buf bmo =
1743       case bmo of
1744         NoBuffering   -> showString "none"
1745         LineBuffering -> showString "line"
1746         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1747         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1748       where
1749        def :: Int
1750        def = bufSize buf
1751
1752 -- ---------------------------------------------------------------------------
1753 -- debugging
1754
1755 #if defined(DEBUG_DUMP)
1756 puts :: String -> IO ()
1757 puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
1758             return ()
1759 #endif
1760
1761 -- -----------------------------------------------------------------------------
1762 -- utils
1763
1764 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
1765 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
1766   do
1767     res <- f
1768     if (res :: CInt) == -1
1769       then do
1770         err <- getErrno
1771         if err == eINTR
1772           then throwErrnoIfMinus1RetryOnBlock loc f on_block
1773           else if err == eWOULDBLOCK || err == eAGAIN
1774                  then do on_block
1775                  else throwErrno loc
1776       else return res
1777
1778 -- -----------------------------------------------------------------------------
1779 -- wrappers to platform-specific constants:
1780
1781 foreign import ccall unsafe "__hscore_supportsTextMode"
1782   tEXT_MODE_SEEK_ALLOWED :: Bool
1783
1784 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1785 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1786 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1787 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt