GHC/Handle.hs

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