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