GHC/Handle.hs

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