GHC/Handle.hs

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