GHC/Handle.hs

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