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