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_stat, 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_stat 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_stat :: FD
 912             -> Maybe (FDType, CDev, CIno)
 913             -> Bool
 914             -> FilePath
 915             -> IOMode
 916             -> Bool
 917             -> IO Handle
 918
 919 fdToHandle_stat 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 -- | Old API kept to avoid breaking clients
 972 fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool
 973             -> IO Handle
 974 fdToHandle' fd mb_type is_socket filepath mode binary
 975  = do
 976        let mb_stat = case mb_type of
 977                         Nothing          -> Nothing
 978                           -- fdToHandle_stat will do the stat:
 979                         Just RegularFile -> Nothing
 980                           -- no stat required for streams etc.:
 981                         Just other       -> Just (other,0,0)
 982        fdToHandle_stat fd mb_stat is_socket filepath mode binary
 983
 984 fdToHandle :: FD -> IO Handle
 985 fdToHandle fd = do
 986    mode <- fdGetMode fd
 987    let fd_str = "<file descriptor: " ++ show fd ++ ">"
 988    fdToHandle_stat fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
 989
 990
 991 #ifndef mingw32_HOST_OS
 992 foreign import ccall unsafe "lockFile"
 993   lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
 994
 995 foreign import ccall unsafe "unlockFile"
 996   unlockFile :: CInt -> IO CInt
 997 #endif
 998
 999 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
1000         -> IO Handle
1001 mkStdHandle fd filepath ha_type buf bmode = do
1002    spares <- newIORef BufferListNil
1003    newFileHandle filepath (stdHandleFinalizer filepath)
1004             (Handle__ { haFD = fd,
1005                         haType = ha_type,
1006                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
1007                         haIsStream = False, -- means FD is blocking on Unix
1008                         haBufferMode = bmode,
1009                         haBuffer = buf,
1010                         haBuffers = spares,
1011                         haOtherSide = Nothing
1012                       })
1013
1014 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
1015 mkFileHandle fd is_stream filepath ha_type binary = do
1016   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
1017
1018 #ifdef mingw32_HOST_OS
1019   -- On Windows, if this is a read/write handle and we are in text mode,
1020   -- turn off buffering.  We don't correctly handle the case of switching
1021   -- from read mode to write mode on a buffered text-mode handle, see bug
1022   -- \#679.
1023   bmode <- case ha_type of
1024                 ReadWriteHandle | not binary -> return NoBuffering
1025                 _other                       -> return bmode
1026 #endif
1027
1028   spares <- newIORef BufferListNil
1029   newFileHandle filepath (handleFinalizer filepath)
1030             (Handle__ { haFD = fd,
1031                         haType = ha_type,
1032                         haIsBin = binary,
1033                         haIsStream = is_stream,
1034                         haBufferMode = bmode,
1035                         haBuffer = buf,
1036                         haBuffers = spares,
1037                         haOtherSide = Nothing
1038                       })
1039
1040 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
1041 mkDuplexHandle fd is_stream filepath binary = do
1042   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
1043   w_spares <- newIORef BufferListNil
1044   let w_handle_ =
1045              Handle__ { haFD = fd,
1046                         haType = WriteHandle,
1047                         haIsBin = binary,
1048                         haIsStream = is_stream,
1049                         haBufferMode = w_bmode,
1050                         haBuffer = w_buf,
1051                         haBuffers = w_spares,
1052                         haOtherSide = Nothing
1053                       }
1054   write_side <- newMVar w_handle_
1055
1056   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
1057   r_spares <- newIORef BufferListNil
1058   let r_handle_ =
1059              Handle__ { haFD = fd,
1060                         haType = ReadHandle,
1061                         haIsBin = binary,
1062                         haIsStream = is_stream,
1063                         haBufferMode = r_bmode,
1064                         haBuffer = r_buf,
1065                         haBuffers = r_spares,
1066                         haOtherSide = Just write_side
1067                       }
1068   read_side <- newMVar r_handle_
1069
1070   addMVarFinalizer write_side (handleFinalizer filepath write_side)
1071   return (DuplexHandle filepath read_side write_side)
1072
1073
1074 initBufferState ReadHandle = ReadBuffer
1075 initBufferState _          = WriteBuffer
1076
1077 -- ---------------------------------------------------------------------------
1078 -- Closing a handle
1079
1080 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
1081 -- computation finishes, if @hdl@ is writable its buffer is flushed as
1082 -- for 'hFlush'.
1083 -- Performing 'hClose' on a handle that has already been closed has no effect;
1084 -- doing so is not an error.  All other operations on a closed handle will fail.
1085 -- If 'hClose' fails for any reason, any further operations (apart from
1086 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
1087 -- closed.
1088
1089 hClose :: Handle -> IO ()
1090 hClose h@(FileHandle _ m)     = do
1091   mb_exc <- hClose' h m
1092   case mb_exc of
1093     Nothing -> return ()
1094     Just e  -> throwIO e
1095 hClose h@(DuplexHandle _ r w) = do
1096   mb_exc1 <- hClose' h w
1097   mb_exc2 <- hClose' h r
1098   case (do mb_exc1; mb_exc2) of
1099      Nothing -> return ()
1100      Just e  -> throwIO e
1101
1102 hClose' h m = withHandle' "hClose" h m $ hClose_help
1103
1104 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
1105 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
1106 -- then closed immediately.  We have to be careful with DuplexHandles
1107 -- though: we have to leave the closing to the finalizer in that case,
1108 -- because the write side may still be in use.
1109 hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
1110 hClose_help handle_ =
1111   case haType handle_ of
1112       ClosedHandle -> return (handle_,Nothing)
1113       _ -> do flushWriteBufferOnly handle_ -- interruptible
1114               hClose_handle_ handle_
1115
1116 hClose_handle_ handle_ = do
1117     let fd = haFD handle_
1118
1119     -- close the file descriptor, but not when this is the read
1120     -- side of a duplex handle.
1121     -- If an exception is raised by the close(), we want to continue
1122     -- to close the handle and release the lock if it has one, then
1123     -- we return the exception to the caller of hClose_help which can
1124     -- raise it if necessary.
1125     maybe_exception <-
1126       case haOtherSide handle_ of
1127         Nothing -> (do
1128                       throwErrnoIfMinus1Retry_ "hClose"
1129 #ifdef mingw32_HOST_OS
1130                                 (closeFd (haIsStream handle_) fd)
1131 #else
1132                                 (c_close fd)
1133 #endif
1134                       return Nothing
1135                     )
1136                      `catchException` \e -> return (Just e)
1137
1138         Just _  -> return Nothing
1139
1140     -- free the spare buffers
1141     writeIORef (haBuffers handle_) BufferListNil
1142     writeIORef (haBuffer  handle_) noBuffer
1143
1144 #ifndef mingw32_HOST_OS
1145     -- unlock it
1146     unlockFile fd
1147 #endif
1148
1149     -- we must set the fd to -1, because the finalizer is going
1150     -- to run eventually and try to close/unlock it.
1151     return (handle_{ haFD        = -1,
1152                      haType      = ClosedHandle
1153                    },
1154             maybe_exception)
1155
1156 {-# NOINLINE noBuffer #-}
1157 noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
1158
1159 -----------------------------------------------------------------------------
1160 -- Detecting and changing the size of a file
1161
1162 -- | For a handle @hdl@ which attached to a physical file,
1163 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1164
1165 hFileSize :: Handle -> IO Integer
1166 hFileSize handle =
1167     withHandle_ "hFileSize" handle $ \ handle_ -> do
1168     case haType handle_ of
1169       ClosedHandle              -> ioe_closedHandle
1170       SemiClosedHandle          -> ioe_closedHandle
1171       _ -> do flushWriteBufferOnly handle_
1172               r <- fdFileSize (haFD handle_)
1173               if r /= -1
1174                  then return r
1175                  else ioException (IOError Nothing InappropriateType "hFileSize"
1176                                    "not a regular file" Nothing)
1177
1178
1179 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1180
1181 hSetFileSize :: Handle -> Integer -> IO ()
1182 hSetFileSize handle size =
1183     withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1184     case haType handle_ of
1185       ClosedHandle              -> ioe_closedHandle
1186       SemiClosedHandle          -> ioe_closedHandle
1187       _ -> do flushWriteBufferOnly handle_
1188               throwErrnoIf (/=0) "hSetFileSize"
1189                  (c_ftruncate (haFD handle_) (fromIntegral size))
1190               return ()
1191
1192 -- ---------------------------------------------------------------------------
1193 -- Detecting the End of Input
1194
1195 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1196 -- 'True' if no further input can be taken from @hdl@ or for a
1197 -- physical file, if the current I\/O position is equal to the length of
1198 -- the file.  Otherwise, it returns 'False'.
1199
1200 hIsEOF :: Handle -> IO Bool
1201 hIsEOF handle =
1202   catch
1203      (do hLookAhead handle; return False)
1204      (\e -> if isEOFError e then return True else ioError e)
1205
1206 -- | The computation 'isEOF' is identical to 'hIsEOF',
1207 -- except that it works only on 'stdin'.
1208
1209 isEOF :: IO Bool
1210 isEOF = hIsEOF stdin
1211
1212 -- ---------------------------------------------------------------------------
1213 -- Looking ahead
1214
1215 -- | Computation 'hLookAhead' returns the next character from the handle
1216 -- without removing it from the input buffer, blocking until a character
1217 -- is available.
1218 --
1219 -- This operation may fail with:
1220 --
1221 --  * 'isEOFError' if the end of file has been reached.
1222
1223 hLookAhead :: Handle -> IO Char
1224 hLookAhead handle = do
1225   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
1226   let ref     = haBuffer handle_
1227       fd      = haFD handle_
1228       is_line = haBufferMode handle_ == LineBuffering
1229   buf <- readIORef ref
1230
1231   -- fill up the read buffer if necessary
1232   new_buf <- if bufferEmpty buf
1233                 then fillReadBuffer fd True (haIsStream handle_) buf
1234                 else return buf
1235
1236   writeIORef ref new_buf
1237
1238   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1239   return c
1240
1241 -- ---------------------------------------------------------------------------
1242 -- Buffering Operations
1243
1244 -- Three kinds of buffering are supported: line-buffering,
1245 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
1246 -- further explanation of what the type represent.
1247
1248 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1249 -- handle @hdl@ on subsequent reads and writes.
1250 --
1251 -- If the buffer mode is changed from 'BlockBuffering' or
1252 -- 'LineBuffering' to 'NoBuffering', then
1253 --
1254 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1255 --
1256 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
1257 --
1258 -- This operation may fail with:
1259 --
1260 --  * 'isPermissionError' if the handle has already been used for reading
1261 --    or writing and the implementation does not allow the buffering mode
1262 --    to be changed.
1263
1264 hSetBuffering :: Handle -> BufferMode -> IO ()
1265 hSetBuffering handle mode =
1266   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1267   case haType handle_ of
1268     ClosedHandle -> ioe_closedHandle
1269     _ -> do
1270          {- Note:
1271             - we flush the old buffer regardless of whether
1272               the new buffer could fit the contents of the old buffer
1273               or not.
1274             - allow a handle's buffering to change even if IO has
1275               occurred (ANSI C spec. does not allow this, nor did
1276               the previous implementation of IO.hSetBuffering).
1277             - a non-standard extension is to allow the buffering
1278               of semi-closed handles to change [sof 6/98]
1279           -}
1280           flushBuffer handle_
1281
1282           let state = initBufferState (haType handle_)
1283           new_buf <-
1284             case mode of
1285                 -- we always have a 1-character read buffer for
1286                 -- unbuffered  handles: it's needed to
1287                 -- support hLookAhead.
1288               NoBuffering            -> allocateBuffer 1 ReadBuffer
1289               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1290               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1291               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1292                                       | otherwise -> allocateBuffer n state
1293           writeIORef (haBuffer handle_) new_buf
1294
1295           -- for input terminals we need to put the terminal into
1296           -- cooked or raw mode depending on the type of buffering.
1297           is_tty <- fdIsTTY (haFD handle_)
1298           when (is_tty && isReadableHandleType (haType handle_)) $
1299                 case mode of
1300 #ifndef mingw32_HOST_OS
1301         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1302         -- for most common uses), so simply disable its use here.
1303                   NoBuffering -> setCooked (haFD handle_) False
1304 #else
1305                   NoBuffering -> return ()
1306 #endif
1307                   _           -> setCooked (haFD handle_) True
1308
1309           -- throw away spare buffers, they might be the wrong size
1310           writeIORef (haBuffers handle_) BufferListNil
1311
1312           return (handle_{ haBufferMode = mode })
1313
1314 -- -----------------------------------------------------------------------------
1315 -- hFlush
1316
1317 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1318 -- in handle @hdl@ to be sent immediately to the operating system.
1319 --
1320 -- This operation may fail with:
1321 --
1322 --  * 'isFullError' if the device is full;
1323 --
1324 --  * 'isPermissionError' if a system resource limit would be exceeded.
1325 --    It is unspecified whether the characters in the buffer are discarded
1326 --    or retained under these circumstances.
1327
1328 hFlush :: Handle -> IO ()
1329 hFlush handle =
1330    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1331    buf <- readIORef (haBuffer handle_)
1332    if bufferIsWritable buf && not (bufferEmpty buf)
1333         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1334                 writeIORef (haBuffer handle_) flushed_buf
1335         else return ()
1336
1337
1338 -- -----------------------------------------------------------------------------
1339 -- Repositioning Handles
1340
1341 data HandlePosn = HandlePosn Handle HandlePosition
1342
1343 instance Eq HandlePosn where
1344     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1345
1346 instance Show HandlePosn where
1347    showsPrec p (HandlePosn h pos) =
1348         showsPrec p h . showString " at position " . shows pos
1349
1350   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1351   -- We represent it as an Integer on the Haskell side, but
1352   -- cheat slightly in that hGetPosn calls upon a C helper
1353   -- that reports the position back via (merely) an Int.
1354 type HandlePosition = Integer
1355
1356 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1357 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1358
1359 hGetPosn :: Handle -> IO HandlePosn
1360 hGetPosn handle = do
1361     posn <- hTell handle
1362     return (HandlePosn handle posn)
1363
1364 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1365 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1366 -- to the position it held at the time of the call to 'hGetPosn'.
1367 --
1368 -- This operation may fail with:
1369 --
1370 --  * 'isPermissionError' if a system resource limit would be exceeded.
1371
1372 hSetPosn :: HandlePosn -> IO ()
1373 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1374
1375 -- ---------------------------------------------------------------------------
1376 -- hSeek
1377
1378 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1379 data SeekMode
1380   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1381   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1382                         -- from the current position.
1383   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1384                         -- from the end of the file.
1385     deriving (Eq, Ord, Ix, Enum, Read, Show)
1386
1387 {- Note:
1388  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1389    seeking at or past EOF.
1390
1391  - we possibly deviate from the report on the issue of seeking within
1392    the buffer and whether to flush it or not.  The report isn't exactly
1393    clear here.
1394 -}
1395
1396 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1397 -- @hdl@ depending on @mode@.
1398 -- The offset @i@ is given in terms of 8-bit bytes.
1399 --
1400 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1401 -- in the current buffer will first cause any items in the output buffer to be
1402 -- written to the device, and then cause the input buffer to be discarded.
1403 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1404 -- subset of the possible positioning operations (for instance, it may only
1405 -- be possible to seek to the end of a tape, or to a positive offset from
1406 -- the beginning or current position).
1407 -- It is not possible to set a negative I\/O position, or for
1408 -- a physical file, an I\/O position beyond the current end-of-file.
1409 --
1410 -- This operation may fail with:
1411 --
1412 --  * 'isPermissionError' if a system resource limit would be exceeded.
1413
1414 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1415 hSeek handle mode offset =
1416     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1417 #   ifdef DEBUG_DUMP
1418     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1419 #   endif
1420     let ref = haBuffer handle_
1421     buf <- readIORef ref
1422     let r = bufRPtr buf
1423         w = bufWPtr buf
1424         fd = haFD handle_
1425
1426     let do_seek =
1427           throwErrnoIfMinus1Retry_ "hSeek"
1428             (c_lseek (haFD handle_) (fromIntegral offset) whence)
1429
1430         whence :: CInt
1431         whence = case mode of
1432                    AbsoluteSeek -> sEEK_SET
1433                    RelativeSeek -> sEEK_CUR
1434                    SeekFromEnd  -> sEEK_END
1435
1436     if bufferIsWritable buf
1437         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1438                 writeIORef ref new_buf
1439                 do_seek
1440         else do
1441
1442     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1443         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1444         else do
1445
1446     new_buf <- flushReadBuffer (haFD handle_) buf
1447     writeIORef ref new_buf
1448     do_seek
1449
1450
1451 hTell :: Handle -> IO Integer
1452 hTell handle =
1453     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1454
1455 #if defined(mingw32_HOST_OS)
1456         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1457         -- so we can't easily calculate the file position using the
1458         -- current buffer size.  Just flush instead.
1459       flushBuffer handle_
1460 #endif
1461       let fd = haFD handle_
1462       posn <- fromIntegral `liftM`
1463                 throwErrnoIfMinus1Retry "hGetPosn"
1464                    (c_lseek fd 0 sEEK_CUR)
1465
1466       let ref = haBuffer handle_
1467       buf <- readIORef ref
1468
1469       let real_posn
1470            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1471            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1472 #     ifdef DEBUG_DUMP
1473       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1474       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1475 #     endif
1476       return real_posn
1477
1478 -- -----------------------------------------------------------------------------
1479 -- Handle Properties
1480
1481 -- A number of operations return information about the properties of a
1482 -- handle.  Each of these operations returns `True' if the handle has
1483 -- the specified property, and `False' otherwise.
1484
1485 hIsOpen :: Handle -> IO Bool
1486 hIsOpen handle =
1487     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1488     case haType handle_ of
1489       ClosedHandle         -> return False
1490       SemiClosedHandle     -> return False
1491       _                    -> return True
1492
1493 hIsClosed :: Handle -> IO Bool
1494 hIsClosed handle =
1495     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1496     case haType handle_ of
1497       ClosedHandle         -> return True
1498       _                    -> return False
1499
1500 {- not defined, nor exported, but mentioned
1501    here for documentation purposes:
1502
1503     hSemiClosed :: Handle -> IO Bool
1504     hSemiClosed h = do
1505        ho <- hIsOpen h
1506        hc <- hIsClosed h
1507        return (not (ho || hc))
1508 -}
1509
1510 hIsReadable :: Handle -> IO Bool
1511 hIsReadable (DuplexHandle _ _ _) = return True
1512 hIsReadable handle =
1513     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1514     case haType handle_ of
1515       ClosedHandle         -> ioe_closedHandle
1516       SemiClosedHandle     -> ioe_closedHandle
1517       htype                -> return (isReadableHandleType htype)
1518
1519 hIsWritable :: Handle -> IO Bool
1520 hIsWritable (DuplexHandle _ _ _) = return True
1521 hIsWritable handle =
1522     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1523     case haType handle_ of
1524       ClosedHandle         -> ioe_closedHandle
1525       SemiClosedHandle     -> ioe_closedHandle
1526       htype                -> return (isWritableHandleType htype)
1527
1528 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1529 -- for @hdl@.
1530
1531 hGetBuffering :: Handle -> IO BufferMode
1532 hGetBuffering handle =
1533     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1534     case haType handle_ of
1535       ClosedHandle         -> ioe_closedHandle
1536       _ ->
1537            -- We're being non-standard here, and allow the buffering
1538            -- of a semi-closed handle to be queried.   -- sof 6/98
1539           return (haBufferMode handle_)  -- could be stricter..
1540
1541 hIsSeekable :: Handle -> IO Bool
1542 hIsSeekable handle =
1543     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1544     case haType handle_ of
1545       ClosedHandle         -> ioe_closedHandle
1546       SemiClosedHandle     -> ioe_closedHandle
1547       AppendHandle         -> return False
1548       _                    -> do t <- fdType (haFD handle_)
1549                                  return ((t == RegularFile    || t == RawDevice)
1550                                          && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))
1551
1552 -- -----------------------------------------------------------------------------
1553 -- Changing echo status (Non-standard GHC extensions)
1554
1555 -- | Set the echoing status of a handle connected to a terminal.
1556
1557 hSetEcho :: Handle -> Bool -> IO ()
1558 hSetEcho handle on = do
1559     isT   <- hIsTerminalDevice handle
1560     if not isT
1561      then return ()
1562      else
1563       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1564       case haType handle_ of
1565          ClosedHandle -> ioe_closedHandle
1566          _            -> setEcho (haFD handle_) on
1567
1568 -- | Get the echoing status of a handle connected to a terminal.
1569
1570 hGetEcho :: Handle -> IO Bool
1571 hGetEcho handle = do
1572     isT   <- hIsTerminalDevice handle
1573     if not isT
1574      then return False
1575      else
1576        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1577        case haType handle_ of
1578          ClosedHandle -> ioe_closedHandle
1579          _            -> getEcho (haFD handle_)
1580
1581 -- | Is the handle connected to a terminal?
1582
1583 hIsTerminalDevice :: Handle -> IO Bool
1584 hIsTerminalDevice handle = do
1585     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1586      case haType handle_ of
1587        ClosedHandle -> ioe_closedHandle
1588        _            -> fdIsTTY (haFD handle_)
1589
1590 -- -----------------------------------------------------------------------------
1591 -- hSetBinaryMode
1592
1593 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1594 -- (See also 'openBinaryFile'.)
1595
1596 hSetBinaryMode :: Handle -> Bool -> IO ()
1597 hSetBinaryMode handle bin =
1598   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1599     do throwErrnoIfMinus1_ "hSetBinaryMode"
1600           (setmode (haFD handle_) bin)
1601        return handle_{haIsBin=bin}
1602
1603 foreign import ccall unsafe "__hscore_setmode"
1604   setmode :: CInt -> Bool -> IO CInt
1605
1606 -- -----------------------------------------------------------------------------
1607 -- Duplicating a Handle
1608
1609 -- | Returns a duplicate of the original handle, with its own buffer.
1610 -- The two Handles will share a file pointer, however.  The original
1611 -- handle's buffer is flushed, including discarding any input data,
1612 -- before the handle is duplicated.
1613
1614 hDuplicate :: Handle -> IO Handle
1615 hDuplicate h@(FileHandle path m) = do
1616   new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
1617   newFileHandle path (handleFinalizer path) new_h_
1618 hDuplicate h@(DuplexHandle path r w) = do
1619   new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
1620   new_w <- newMVar new_w_
1621   new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
1622   new_r <- newMVar new_r_
1623   addMVarFinalizer new_w (handleFinalizer path new_w)
1624   return (DuplexHandle path new_r new_w)
1625
1626 dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
1627           -> IO (Handle__, Handle__)
1628 dupHandle h other_side h_ = do
1629   -- flush the buffer first, so we don't have to copy its contents
1630   flushBuffer h_
1631   new_fd <- case other_side of
1632                 Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
1633                 Just r -> withHandle_' "dupHandle" h r (return . haFD)
1634   dupHandle_ other_side h_ new_fd
1635
1636 dupHandleTo other_side hto_ h_ = do
1637   flushBuffer h_
1638   -- Windows' dup2 does not return the new descriptor, unlike Unix
1639   throwErrnoIfMinus1 "dupHandleTo" $
1640         c_dup2 (haFD h_) (haFD hto_)
1641   dupHandle_ other_side h_ (haFD hto_)
1642
1643 dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
1644            -> IO (Handle__, Handle__)
1645 dupHandle_ other_side h_ new_fd = do
1646   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1647   ioref <- newIORef buffer
1648   ioref_buffers <- newIORef BufferListNil
1649
1650   let new_handle_ = h_{ haFD = new_fd,
1651                         haBuffer = ioref,
1652                         haBuffers = ioref_buffers,
1653                         haOtherSide = other_side }
1654   return (h_, new_handle_)
1655
1656 -- -----------------------------------------------------------------------------
1657 -- Replacing a Handle
1658
1659 {- |
1660 Makes the second handle a duplicate of the first handle.  The second
1661 handle will be closed first, if it is not already.
1662
1663 This can be used to retarget the standard Handles, for example:
1664
1665 > do h <- openFile "mystdout" WriteMode
1666 >    hDuplicateTo h stdout
1667 -}
1668
1669 hDuplicateTo :: Handle -> Handle -> IO ()
1670 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1671  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1672    _ <- hClose_help h2_
1673    withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
1674 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1675  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1676    _ <- hClose_help w2_
1677    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
1678  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1679    _ <- hClose_help r2_
1680    withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
1681 hDuplicateTo h1 _ =
1682    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1683                 "handles are incompatible" Nothing)
1684
1685 -- ---------------------------------------------------------------------------
1686 -- showing Handles.
1687 --
1688 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1689 -- than the (pure) instance of 'Show' for 'Handle'.
1690
1691 hShow :: Handle -> IO String
1692 hShow h@(FileHandle path _) = showHandle' path False h
1693 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1694
1695 showHandle' filepath is_duplex h =
1696   withHandle_ "showHandle" h $ \hdl_ ->
1697     let
1698      showType | is_duplex = showString "duplex (read-write)"
1699               | otherwise = shows (haType hdl_)
1700     in
1701     return
1702       (( showChar '{' .
1703         showHdl (haType hdl_)
1704             (showString "loc=" . showString filepath . showChar ',' .
1705              showString "type=" . showType . showChar ',' .
1706              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1707              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1708       ) "")
1709    where
1710
1711     showHdl :: HandleType -> ShowS -> ShowS
1712     showHdl ht cont =
1713        case ht of
1714         ClosedHandle  -> shows ht . showString "}"
1715         _ -> cont
1716
1717     showBufMode :: Buffer -> BufferMode -> ShowS
1718     showBufMode buf bmo =
1719       case bmo of
1720         NoBuffering   -> showString "none"
1721         LineBuffering -> showString "line"
1722         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1723         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1724       where
1725        def :: Int
1726        def = bufSize buf
1727
1728 -- ---------------------------------------------------------------------------
1729 -- debugging
1730
1731 #if defined(DEBUG_DUMP)
1732 puts :: String -> IO ()
1733 puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
1734             return ()
1735 #endif
1736
1737 -- -----------------------------------------------------------------------------
1738 -- utils
1739
1740 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
1741 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
1742   do
1743     res <- f
1744     if (res :: CInt) == -1
1745       then do
1746         err <- getErrno
1747         if err == eINTR
1748           then throwErrnoIfMinus1RetryOnBlock loc f on_block
1749           else if err == eWOULDBLOCK || err == eAGAIN
1750                  then do on_block
1751                  else throwErrno loc
1752       else return res
1753
1754 -- -----------------------------------------------------------------------------
1755 -- wrappers to platform-specific constants:
1756
1757 foreign import ccall unsafe "__hscore_supportsTextMode"
1758   tEXT_MODE_SEEK_ALLOWED :: Bool
1759
1760 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1761 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1762 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1763 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt