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