GHC/Handle.hs

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