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, 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 =
1249   wantReadableHandle "hLookAhead"  handle hLookAhead'
1250
1251 hLookAhead' :: Handle__ -> IO Char
1252 hLookAhead' handle_ = do
1253   let ref     = haBuffer handle_
1254       fd      = haFD handle_
1255       is_line = haBufferMode handle_ == LineBuffering
1256   buf <- readIORef ref
1257
1258   -- fill up the read buffer if necessary
1259   new_buf <- if bufferEmpty buf
1260                 then fillReadBuffer fd True (haIsStream handle_) buf
1261                 else return buf
1262
1263   writeIORef ref new_buf
1264
1265   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1266   return c
1267
1268 -- ---------------------------------------------------------------------------
1269 -- Buffering Operations
1270
1271 -- Three kinds of buffering are supported: line-buffering,
1272 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
1273 -- further explanation of what the type represent.
1274
1275 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1276 -- handle @hdl@ on subsequent reads and writes.
1277 --
1278 -- If the buffer mode is changed from 'BlockBuffering' or
1279 -- 'LineBuffering' to 'NoBuffering', then
1280 --
1281 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1282 --
1283 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
1284 --
1285 -- This operation may fail with:
1286 --
1287 --  * 'isPermissionError' if the handle has already been used for reading
1288 --    or writing and the implementation does not allow the buffering mode
1289 --    to be changed.
1290
1291 hSetBuffering :: Handle -> BufferMode -> IO ()
1292 hSetBuffering handle mode =
1293   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1294   case haType handle_ of
1295     ClosedHandle -> ioe_closedHandle
1296     _ -> do
1297          {- Note:
1298             - we flush the old buffer regardless of whether
1299               the new buffer could fit the contents of the old buffer
1300               or not.
1301             - allow a handle's buffering to change even if IO has
1302               occurred (ANSI C spec. does not allow this, nor did
1303               the previous implementation of IO.hSetBuffering).
1304             - a non-standard extension is to allow the buffering
1305               of semi-closed handles to change [sof 6/98]
1306           -}
1307           flushBuffer handle_
1308
1309           let state = initBufferState (haType handle_)
1310           new_buf <-
1311             case mode of
1312                 -- we always have a 1-character read buffer for
1313                 -- unbuffered  handles: it's needed to
1314                 -- support hLookAhead.
1315               NoBuffering            -> allocateBuffer 1 ReadBuffer
1316               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1317               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1318               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1319                                       | otherwise -> allocateBuffer n state
1320           writeIORef (haBuffer handle_) new_buf
1321
1322           -- for input terminals we need to put the terminal into
1323           -- cooked or raw mode depending on the type of buffering.
1324           is_tty <- fdIsTTY (haFD handle_)
1325           when (is_tty && isReadableHandleType (haType handle_)) $
1326                 case mode of
1327 #ifndef mingw32_HOST_OS
1328         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1329         -- for most common uses), so simply disable its use here.
1330                   NoBuffering -> setCooked (haFD handle_) False
1331 #else
1332                   NoBuffering -> return ()
1333 #endif
1334                   _           -> setCooked (haFD handle_) True
1335
1336           -- throw away spare buffers, they might be the wrong size
1337           writeIORef (haBuffers handle_) BufferListNil
1338
1339           return (handle_{ haBufferMode = mode })
1340
1341 -- -----------------------------------------------------------------------------
1342 -- hFlush
1343
1344 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1345 -- in handle @hdl@ to be sent immediately to the operating system.
1346 --
1347 -- This operation may fail with:
1348 --
1349 --  * 'isFullError' if the device is full;
1350 --
1351 --  * 'isPermissionError' if a system resource limit would be exceeded.
1352 --    It is unspecified whether the characters in the buffer are discarded
1353 --    or retained under these circumstances.
1354
1355 hFlush :: Handle -> IO ()
1356 hFlush handle =
1357    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1358    buf <- readIORef (haBuffer handle_)
1359    if bufferIsWritable buf && not (bufferEmpty buf)
1360         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1361                 writeIORef (haBuffer handle_) flushed_buf
1362         else return ()
1363
1364
1365 -- -----------------------------------------------------------------------------
1366 -- Repositioning Handles
1367
1368 data HandlePosn = HandlePosn Handle HandlePosition
1369
1370 instance Eq HandlePosn where
1371     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1372
1373 instance Show HandlePosn where
1374    showsPrec p (HandlePosn h pos) =
1375         showsPrec p h . showString " at position " . shows pos
1376
1377   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1378   -- We represent it as an Integer on the Haskell side, but
1379   -- cheat slightly in that hGetPosn calls upon a C helper
1380   -- that reports the position back via (merely) an Int.
1381 type HandlePosition = Integer
1382
1383 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1384 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1385
1386 hGetPosn :: Handle -> IO HandlePosn
1387 hGetPosn handle = do
1388     posn <- hTell handle
1389     return (HandlePosn handle posn)
1390
1391 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1392 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1393 -- to the position it held at the time of the call to 'hGetPosn'.
1394 --
1395 -- This operation may fail with:
1396 --
1397 --  * 'isPermissionError' if a system resource limit would be exceeded.
1398
1399 hSetPosn :: HandlePosn -> IO ()
1400 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1401
1402 -- ---------------------------------------------------------------------------
1403 -- hSeek
1404
1405 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1406 data SeekMode
1407   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1408   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1409                         -- from the current position.
1410   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1411                         -- from the end of the file.
1412     deriving (Eq, Ord, Ix, Enum, Read, Show)
1413
1414 {- Note:
1415  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1416    seeking at or past EOF.
1417
1418  - we possibly deviate from the report on the issue of seeking within
1419    the buffer and whether to flush it or not.  The report isn't exactly
1420    clear here.
1421 -}
1422
1423 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1424 -- @hdl@ depending on @mode@.
1425 -- The offset @i@ is given in terms of 8-bit bytes.
1426 --
1427 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1428 -- in the current buffer will first cause any items in the output buffer to be
1429 -- written to the device, and then cause the input buffer to be discarded.
1430 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1431 -- subset of the possible positioning operations (for instance, it may only
1432 -- be possible to seek to the end of a tape, or to a positive offset from
1433 -- the beginning or current position).
1434 -- It is not possible to set a negative I\/O position, or for
1435 -- a physical file, an I\/O position beyond the current end-of-file.
1436 --
1437 -- This operation may fail with:
1438 --
1439 --  * 'isPermissionError' if a system resource limit would be exceeded.
1440
1441 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1442 hSeek handle mode offset =
1443     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1444 #   ifdef DEBUG_DUMP
1445     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1446 #   endif
1447     let ref = haBuffer handle_
1448     buf <- readIORef ref
1449     let r = bufRPtr buf
1450         w = bufWPtr buf
1451         fd = haFD handle_
1452
1453     let do_seek =
1454           throwErrnoIfMinus1Retry_ "hSeek"
1455             (c_lseek (haFD handle_) (fromIntegral offset) whence)
1456
1457         whence :: CInt
1458         whence = case mode of
1459                    AbsoluteSeek -> sEEK_SET
1460                    RelativeSeek -> sEEK_CUR
1461                    SeekFromEnd  -> sEEK_END
1462
1463     if bufferIsWritable buf
1464         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1465                 writeIORef ref new_buf
1466                 do_seek
1467         else do
1468
1469     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1470         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1471         else do
1472
1473     new_buf <- flushReadBuffer (haFD handle_) buf
1474     writeIORef ref new_buf
1475     do_seek
1476
1477
1478 hTell :: Handle -> IO Integer
1479 hTell handle =
1480     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1481
1482 #if defined(mingw32_HOST_OS)
1483         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1484         -- so we can't easily calculate the file position using the
1485         -- current buffer size.  Just flush instead.
1486       flushBuffer handle_
1487 #endif
1488       let fd = haFD handle_
1489       posn <- fromIntegral `liftM`
1490                 throwErrnoIfMinus1Retry "hGetPosn"
1491                    (c_lseek fd 0 sEEK_CUR)
1492
1493       let ref = haBuffer handle_
1494       buf <- readIORef ref
1495
1496       let real_posn
1497            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1498            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1499 #     ifdef DEBUG_DUMP
1500       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1501       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1502 #     endif
1503       return real_posn
1504
1505 -- -----------------------------------------------------------------------------
1506 -- Handle Properties
1507
1508 -- A number of operations return information about the properties of a
1509 -- handle.  Each of these operations returns `True' if the handle has
1510 -- the specified property, and `False' otherwise.
1511
1512 hIsOpen :: Handle -> IO Bool
1513 hIsOpen handle =
1514     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1515     case haType handle_ of
1516       ClosedHandle         -> return False
1517       SemiClosedHandle     -> return False
1518       _                    -> return True
1519
1520 hIsClosed :: Handle -> IO Bool
1521 hIsClosed handle =
1522     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1523     case haType handle_ of
1524       ClosedHandle         -> return True
1525       _                    -> return False
1526
1527 {- not defined, nor exported, but mentioned
1528    here for documentation purposes:
1529
1530     hSemiClosed :: Handle -> IO Bool
1531     hSemiClosed h = do
1532        ho <- hIsOpen h
1533        hc <- hIsClosed h
1534        return (not (ho || hc))
1535 -}
1536
1537 hIsReadable :: Handle -> IO Bool
1538 hIsReadable (DuplexHandle _ _ _) = return True
1539 hIsReadable handle =
1540     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1541     case haType handle_ of
1542       ClosedHandle         -> ioe_closedHandle
1543       SemiClosedHandle     -> ioe_closedHandle
1544       htype                -> return (isReadableHandleType htype)
1545
1546 hIsWritable :: Handle -> IO Bool
1547 hIsWritable (DuplexHandle _ _ _) = return True
1548 hIsWritable handle =
1549     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1550     case haType handle_ of
1551       ClosedHandle         -> ioe_closedHandle
1552       SemiClosedHandle     -> ioe_closedHandle
1553       htype                -> return (isWritableHandleType htype)
1554
1555 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1556 -- for @hdl@.
1557
1558 hGetBuffering :: Handle -> IO BufferMode
1559 hGetBuffering handle =
1560     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1561     case haType handle_ of
1562       ClosedHandle         -> ioe_closedHandle
1563       _ ->
1564            -- We're being non-standard here, and allow the buffering
1565            -- of a semi-closed handle to be queried.   -- sof 6/98
1566           return (haBufferMode handle_)  -- could be stricter..
1567
1568 hIsSeekable :: Handle -> IO Bool
1569 hIsSeekable handle =
1570     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1571     case haType handle_ of
1572       ClosedHandle         -> ioe_closedHandle
1573       SemiClosedHandle     -> ioe_closedHandle
1574       AppendHandle         -> return False
1575       _                    -> do t <- fdType (haFD handle_)
1576                                  return ((t == RegularFile    || t == RawDevice)
1577                                          && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))
1578
1579 -- -----------------------------------------------------------------------------
1580 -- Changing echo status (Non-standard GHC extensions)
1581
1582 -- | Set the echoing status of a handle connected to a terminal.
1583
1584 hSetEcho :: Handle -> Bool -> IO ()
1585 hSetEcho handle on = do
1586     isT   <- hIsTerminalDevice handle
1587     if not isT
1588      then return ()
1589      else
1590       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1591       case haType handle_ of
1592          ClosedHandle -> ioe_closedHandle
1593          _            -> setEcho (haFD handle_) on
1594
1595 -- | Get the echoing status of a handle connected to a terminal.
1596
1597 hGetEcho :: Handle -> IO Bool
1598 hGetEcho handle = do
1599     isT   <- hIsTerminalDevice handle
1600     if not isT
1601      then return False
1602      else
1603        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1604        case haType handle_ of
1605          ClosedHandle -> ioe_closedHandle
1606          _            -> getEcho (haFD handle_)
1607
1608 -- | Is the handle connected to a terminal?
1609
1610 hIsTerminalDevice :: Handle -> IO Bool
1611 hIsTerminalDevice handle = do
1612     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1613      case haType handle_ of
1614        ClosedHandle -> ioe_closedHandle
1615        _            -> fdIsTTY (haFD handle_)
1616
1617 -- -----------------------------------------------------------------------------
1618 -- hSetBinaryMode
1619
1620 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1621 -- (See also 'openBinaryFile'.)
1622
1623 hSetBinaryMode :: Handle -> Bool -> IO ()
1624 hSetBinaryMode handle bin =
1625   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1626     do throwErrnoIfMinus1_ "hSetBinaryMode"
1627           (setmode (haFD handle_) bin)
1628        return handle_{haIsBin=bin}
1629
1630 foreign import ccall unsafe "__hscore_setmode"
1631   setmode :: CInt -> Bool -> IO CInt
1632
1633 -- -----------------------------------------------------------------------------
1634 -- Duplicating a Handle
1635
1636 -- | Returns a duplicate of the original handle, with its own buffer.
1637 -- The two Handles will share a file pointer, however.  The original
1638 -- handle's buffer is flushed, including discarding any input data,
1639 -- before the handle is duplicated.
1640
1641 hDuplicate :: Handle -> IO Handle
1642 hDuplicate h@(FileHandle path m) = do
1643   new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
1644   newFileHandle path (handleFinalizer path) new_h_
1645 hDuplicate h@(DuplexHandle path r w) = do
1646   new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
1647   new_w <- newMVar new_w_
1648   new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
1649   new_r <- newMVar new_r_
1650   addMVarFinalizer new_w (handleFinalizer path new_w)
1651   return (DuplexHandle path new_r new_w)
1652
1653 dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
1654           -> IO (Handle__, Handle__)
1655 dupHandle h other_side h_ = do
1656   -- flush the buffer first, so we don't have to copy its contents
1657   flushBuffer h_
1658   new_fd <- case other_side of
1659                 Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
1660                 Just r -> withHandle_' "dupHandle" h r (return . haFD)
1661   dupHandle_ other_side h_ new_fd
1662
1663 dupHandleTo other_side hto_ h_ = do
1664   flushBuffer h_
1665   -- Windows' dup2 does not return the new descriptor, unlike Unix
1666   throwErrnoIfMinus1 "dupHandleTo" $
1667         c_dup2 (haFD h_) (haFD hto_)
1668   dupHandle_ other_side h_ (haFD hto_)
1669
1670 dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
1671            -> IO (Handle__, Handle__)
1672 dupHandle_ other_side h_ new_fd = do
1673   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1674   ioref <- newIORef buffer
1675   ioref_buffers <- newIORef BufferListNil
1676
1677   let new_handle_ = h_{ haFD = new_fd,
1678                         haBuffer = ioref,
1679                         haBuffers = ioref_buffers,
1680                         haOtherSide = other_side }
1681   return (h_, new_handle_)
1682
1683 -- -----------------------------------------------------------------------------
1684 -- Replacing a Handle
1685
1686 {- |
1687 Makes the second handle a duplicate of the first handle.  The second
1688 handle will be closed first, if it is not already.
1689
1690 This can be used to retarget the standard Handles, for example:
1691
1692 > do h <- openFile "mystdout" WriteMode
1693 >    hDuplicateTo h stdout
1694 -}
1695
1696 hDuplicateTo :: Handle -> Handle -> IO ()
1697 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1698  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1699    _ <- hClose_help h2_
1700    withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
1701 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1702  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1703    _ <- hClose_help w2_
1704    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
1705  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1706    _ <- hClose_help r2_
1707    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
1708 hDuplicateTo h1 _ =
1709    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1710                 "handles are incompatible" Nothing)
1711
1712 -- ---------------------------------------------------------------------------
1713 -- showing Handles.
1714 --
1715 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1716 -- than the (pure) instance of 'Show' for 'Handle'.
1717
1718 hShow :: Handle -> IO String
1719 hShow h@(FileHandle path _) = showHandle' path False h
1720 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1721
1722 showHandle' filepath is_duplex h =
1723   withHandle_ "showHandle" h $ \hdl_ ->
1724     let
1725      showType | is_duplex = showString "duplex (read-write)"
1726               | otherwise = shows (haType hdl_)
1727     in
1728     return
1729       (( showChar '{' .
1730         showHdl (haType hdl_)
1731             (showString "loc=" . showString filepath . showChar ',' .
1732              showString "type=" . showType . showChar ',' .
1733              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1734              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1735       ) "")
1736    where
1737
1738     showHdl :: HandleType -> ShowS -> ShowS
1739     showHdl ht cont =
1740        case ht of
1741         ClosedHandle  -> shows ht . showString "}"
1742         _ -> cont
1743
1744     showBufMode :: Buffer -> BufferMode -> ShowS
1745     showBufMode buf bmo =
1746       case bmo of
1747         NoBuffering   -> showString "none"
1748         LineBuffering -> showString "line"
1749         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1750         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1751       where
1752        def :: Int
1753        def = bufSize buf
1754
1755 -- ---------------------------------------------------------------------------
1756 -- debugging
1757
1758 #if defined(DEBUG_DUMP)
1759 puts :: String -> IO ()
1760 puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
1761             return ()
1762 #endif
1763
1764 -- -----------------------------------------------------------------------------
1765 -- utils
1766
1767 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
1768 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
1769   do
1770     res <- f
1771     if (res :: CInt) == -1
1772       then do
1773         err <- getErrno
1774         if err == eINTR
1775           then throwErrnoIfMinus1RetryOnBlock loc f on_block
1776           else if err == eWOULDBLOCK || err == eAGAIN
1777                  then do on_block
1778                  else throwErrno loc
1779       else return res
1780
1781 -- -----------------------------------------------------------------------------
1782 -- wrappers to platform-specific constants:
1783
1784 foreign import ccall unsafe "__hscore_supportsTextMode"
1785   tEXT_MODE_SEEK_ALLOWED :: Bool
1786
1787 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1788 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1789 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1790 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt