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, hSetFileSize, 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 and changing 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 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1032
1033 hSetFileSize :: Handle -> Integer -> IO ()
1034 hSetFileSize handle size =
1035     withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1036     case haType handle_ of
1037       ClosedHandle              -> ioe_closedHandle
1038       SemiClosedHandle          -> ioe_closedHandle
1039       _ -> do flushWriteBufferOnly handle_
1040               throwErrnoIf (/=0) "hSetFileSize"
1041                  (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
1042               return ()
1043
1044 -- ---------------------------------------------------------------------------
1045 -- Detecting the End of Input
1046
1047 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1048 -- 'True' if no further input can be taken from @hdl@ or for a
1049 -- physical file, if the current I\/O position is equal to the length of
1050 -- the file.  Otherwise, it returns 'False'.
1051
1052 hIsEOF :: Handle -> IO Bool
1053 hIsEOF handle =
1054   catch
1055      (do hLookAhead handle; return False)
1056      (\e -> if isEOFError e then return True else ioError e)
1057
1058 -- | The computation 'isEOF' is identical to 'hIsEOF',
1059 -- except that it works only on 'stdin'.
1060
1061 isEOF :: IO Bool
1062 isEOF = hIsEOF stdin
1063
1064 -- ---------------------------------------------------------------------------
1065 -- Looking ahead
1066
1067 -- | Computation 'hLookAhead' returns the next character from the handle
1068 -- without removing it from the input buffer, blocking until a character
1069 -- is available.
1070 --
1071 -- This operation may fail with:
1072 --
1073 --  * 'isEOFError' if the end of file has been reached.
1074
1075 hLookAhead :: Handle -> IO Char
1076 hLookAhead handle = do
1077   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
1078   let ref     = haBuffer handle_
1079       fd      = haFD handle_
1080       is_line = haBufferMode handle_ == LineBuffering
1081   buf <- readIORef ref
1082
1083   -- fill up the read buffer if necessary
1084   new_buf <- if bufferEmpty buf
1085                 then fillReadBuffer fd is_line (haIsStream handle_) buf
1086                 else return buf
1087
1088   writeIORef ref new_buf
1089
1090   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1091   return c
1092
1093 -- ---------------------------------------------------------------------------
1094 -- Buffering Operations
1095
1096 -- Three kinds of buffering are supported: line-buffering,
1097 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
1098 -- further explanation of what the type represent.
1099
1100 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1101 -- handle @hdl@ on subsequent reads and writes.
1102 --
1103 -- If the buffer mode is changed from 'BlockBuffering' or
1104 -- 'LineBuffering' to 'NoBuffering', then
1105 --
1106 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1107 --
1108 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
1109 --
1110 -- This operation may fail with:
1111 --
1112 --  * 'isPermissionError' if the handle has already been used for reading
1113 --    or writing and the implementation does not allow the buffering mode
1114 --    to be changed.
1115
1116 hSetBuffering :: Handle -> BufferMode -> IO ()
1117 hSetBuffering handle mode =
1118   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1119   case haType handle_ of
1120     ClosedHandle -> ioe_closedHandle
1121     _ -> do
1122          {- Note:
1123             - we flush the old buffer regardless of whether
1124               the new buffer could fit the contents of the old buffer
1125               or not.
1126             - allow a handle's buffering to change even if IO has
1127               occurred (ANSI C spec. does not allow this, nor did
1128               the previous implementation of IO.hSetBuffering).
1129             - a non-standard extension is to allow the buffering
1130               of semi-closed handles to change [sof 6/98]
1131           -}
1132           flushBuffer handle_
1133
1134           let state = initBufferState (haType handle_)
1135           new_buf <-
1136             case mode of
1137                 -- we always have a 1-character read buffer for
1138                 -- unbuffered  handles: it's needed to
1139                 -- support hLookAhead.
1140               NoBuffering            -> allocateBuffer 1 ReadBuffer
1141               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1142               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1143               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1144                                       | otherwise -> allocateBuffer n state
1145           writeIORef (haBuffer handle_) new_buf
1146
1147           -- for input terminals we need to put the terminal into
1148           -- cooked or raw mode depending on the type of buffering.
1149           is_tty <- fdIsTTY (haFD handle_)
1150           when (is_tty && isReadableHandleType (haType handle_)) $
1151                 case mode of
1152 #ifndef mingw32_TARGET_OS
1153         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1154         -- for most common uses), so simply disable its use here.
1155                   NoBuffering -> setCooked (haFD handle_) False
1156 #endif
1157                   _           -> setCooked (haFD handle_) True
1158
1159           -- throw away spare buffers, they might be the wrong size
1160           writeIORef (haBuffers handle_) BufferListNil
1161
1162           return (handle_{ haBufferMode = mode })
1163
1164 -- -----------------------------------------------------------------------------
1165 -- hFlush
1166
1167 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1168 -- in handle @hdl@ to be sent immediately to the operating system.
1169 --
1170 -- This operation may fail with:
1171 --
1172 --  * 'isFullError' if the device is full;
1173 --
1174 --  * 'isPermissionError' if a system resource limit would be exceeded.
1175 --    It is unspecified whether the characters in the buffer are discarded
1176 --    or retained under these circumstances.
1177
1178 hFlush :: Handle -> IO ()
1179 hFlush handle =
1180    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1181    buf <- readIORef (haBuffer handle_)
1182    if bufferIsWritable buf && not (bufferEmpty buf)
1183         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1184                 writeIORef (haBuffer handle_) flushed_buf
1185         else return ()
1186
1187
1188 -- -----------------------------------------------------------------------------
1189 -- Repositioning Handles
1190
1191 data HandlePosn = HandlePosn Handle HandlePosition
1192
1193 instance Eq HandlePosn where
1194     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1195
1196 instance Show HandlePosn where
1197    showsPrec p (HandlePosn h pos) =
1198         showsPrec p h . showString " at position " . shows pos
1199
1200   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1201   -- We represent it as an Integer on the Haskell side, but
1202   -- cheat slightly in that hGetPosn calls upon a C helper
1203   -- that reports the position back via (merely) an Int.
1204 type HandlePosition = Integer
1205
1206 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1207 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1208
1209 hGetPosn :: Handle -> IO HandlePosn
1210 hGetPosn handle = do
1211     posn <- hTell handle
1212     return (HandlePosn handle posn)
1213
1214 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1215 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1216 -- to the position it held at the time of the call to 'hGetPosn'.
1217 --
1218 -- This operation may fail with:
1219 --
1220 --  * 'isPermissionError' if a system resource limit would be exceeded.
1221
1222 hSetPosn :: HandlePosn -> IO ()
1223 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1224
1225 -- ---------------------------------------------------------------------------
1226 -- hSeek
1227
1228 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1229 data SeekMode
1230   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1231   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1232                         -- from the current position.
1233   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1234                         -- from the end of the file.
1235     deriving (Eq, Ord, Ix, Enum, Read, Show)
1236
1237 {- Note:
1238  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1239    seeking at or past EOF.
1240
1241  - we possibly deviate from the report on the issue of seeking within
1242    the buffer and whether to flush it or not.  The report isn't exactly
1243    clear here.
1244 -}
1245
1246 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1247 -- @hdl@ depending on @mode@.
1248 -- The offset @i@ is given in terms of 8-bit bytes.
1249 --
1250 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1251 -- in the current buffer will first cause any items in the output buffer to be
1252 -- written to the device, and then cause the input buffer to be discarded.
1253 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1254 -- subset of the possible positioning operations (for instance, it may only
1255 -- be possible to seek to the end of a tape, or to a positive offset from
1256 -- the beginning or current position).
1257 -- It is not possible to set a negative I\/O position, or for
1258 -- a physical file, an I\/O position beyond the current end-of-file.
1259 --
1260 -- This operation may fail with:
1261 --
1262 --  * 'isPermissionError' if a system resource limit would be exceeded.
1263
1264 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1265 hSeek handle mode offset =
1266     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1267 #   ifdef DEBUG_DUMP
1268     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1269 #   endif
1270     let ref = haBuffer handle_
1271     buf <- readIORef ref
1272     let r = bufRPtr buf
1273         w = bufWPtr buf
1274         fd = haFD handle_
1275
1276     let do_seek =
1277           throwErrnoIfMinus1Retry_ "hSeek"
1278             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1279
1280         whence :: CInt
1281         whence = case mode of
1282                    AbsoluteSeek -> sEEK_SET
1283                    RelativeSeek -> sEEK_CUR
1284                    SeekFromEnd  -> sEEK_END
1285
1286     if bufferIsWritable buf
1287         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1288                 writeIORef ref new_buf
1289                 do_seek
1290         else do
1291
1292     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1293         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1294         else do
1295
1296     new_buf <- flushReadBuffer (haFD handle_) buf
1297     writeIORef ref new_buf
1298     do_seek
1299
1300
1301 hTell :: Handle -> IO Integer
1302 hTell handle =
1303     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1304
1305 #if defined(mingw32_TARGET_OS)
1306         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1307         -- so we can't easily calculate the file position using the
1308         -- current buffer size.  Just flush instead.
1309       flushBuffer handle_
1310 #endif
1311       let fd = fromIntegral (haFD handle_)
1312       posn <- fromIntegral `liftM`
1313                 throwErrnoIfMinus1Retry "hGetPosn"
1314                    (c_lseek fd 0 sEEK_CUR)
1315
1316       let ref = haBuffer handle_
1317       buf <- readIORef ref
1318
1319       let real_posn
1320            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1321            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1322 #     ifdef DEBUG_DUMP
1323       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1324       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1325 #     endif
1326       return real_posn
1327
1328 -- -----------------------------------------------------------------------------
1329 -- Handle Properties
1330
1331 -- A number of operations return information about the properties of a
1332 -- handle.  Each of these operations returns `True' if the handle has
1333 -- the specified property, and `False' otherwise.
1334
1335 hIsOpen :: Handle -> IO Bool
1336 hIsOpen handle =
1337     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1338     case haType handle_ of
1339       ClosedHandle         -> return False
1340       SemiClosedHandle     -> return False
1341       _                    -> return True
1342
1343 hIsClosed :: Handle -> IO Bool
1344 hIsClosed handle =
1345     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1346     case haType handle_ of
1347       ClosedHandle         -> return True
1348       _                    -> return False
1349
1350 {- not defined, nor exported, but mentioned
1351    here for documentation purposes:
1352
1353     hSemiClosed :: Handle -> IO Bool
1354     hSemiClosed h = do
1355        ho <- hIsOpen h
1356        hc <- hIsClosed h
1357        return (not (ho || hc))
1358 -}
1359
1360 hIsReadable :: Handle -> IO Bool
1361 hIsReadable (DuplexHandle _ _ _) = return True
1362 hIsReadable handle =
1363     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1364     case haType handle_ of
1365       ClosedHandle         -> ioe_closedHandle
1366       SemiClosedHandle     -> ioe_closedHandle
1367       htype                -> return (isReadableHandleType htype)
1368
1369 hIsWritable :: Handle -> IO Bool
1370 hIsWritable (DuplexHandle _ _ _) = return True
1371 hIsWritable handle =
1372     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1373     case haType handle_ of
1374       ClosedHandle         -> ioe_closedHandle
1375       SemiClosedHandle     -> ioe_closedHandle
1376       htype                -> return (isWritableHandleType htype)
1377
1378 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1379 -- for @hdl@.
1380
1381 hGetBuffering :: Handle -> IO BufferMode
1382 hGetBuffering handle =
1383     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1384     case haType handle_ of
1385       ClosedHandle         -> ioe_closedHandle
1386       _ ->
1387            -- We're being non-standard here, and allow the buffering
1388            -- of a semi-closed handle to be queried.   -- sof 6/98
1389           return (haBufferMode handle_)  -- could be stricter..
1390
1391 hIsSeekable :: Handle -> IO Bool
1392 hIsSeekable handle =
1393     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1394     case haType handle_ of
1395       ClosedHandle         -> ioe_closedHandle
1396       SemiClosedHandle     -> ioe_closedHandle
1397       AppendHandle         -> return False
1398       _                    -> do t <- fdType (haFD handle_)
1399                                  return (t == RegularFile
1400                                          && (haIsBin handle_
1401                                                 || tEXT_MODE_SEEK_ALLOWED))
1402
1403 -- -----------------------------------------------------------------------------
1404 -- Changing echo status (Non-standard GHC extensions)
1405
1406 -- | Set the echoing status of a handle connected to a terminal.
1407
1408 hSetEcho :: Handle -> Bool -> IO ()
1409 hSetEcho handle on = do
1410     isT   <- hIsTerminalDevice handle
1411     if not isT
1412      then return ()
1413      else
1414       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1415       case haType handle_ of
1416          ClosedHandle -> ioe_closedHandle
1417          _            -> setEcho (haFD handle_) on
1418
1419 -- | Get the echoing status of a handle connected to a terminal.
1420
1421 hGetEcho :: Handle -> IO Bool
1422 hGetEcho handle = do
1423     isT   <- hIsTerminalDevice handle
1424     if not isT
1425      then return False
1426      else
1427        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1428        case haType handle_ of
1429          ClosedHandle -> ioe_closedHandle
1430          _            -> getEcho (haFD handle_)
1431
1432 -- | Is the handle connected to a terminal?
1433
1434 hIsTerminalDevice :: Handle -> IO Bool
1435 hIsTerminalDevice handle = do
1436     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1437      case haType handle_ of
1438        ClosedHandle -> ioe_closedHandle
1439        _            -> fdIsTTY (haFD handle_)
1440
1441 -- -----------------------------------------------------------------------------
1442 -- hSetBinaryMode
1443
1444 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1445 -- (See also 'openBinaryFile'.)
1446
1447 hSetBinaryMode :: Handle -> Bool -> IO ()
1448 hSetBinaryMode handle bin =
1449   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1450     do throwErrnoIfMinus1_ "hSetBinaryMode"
1451           (setmode (fromIntegral (haFD handle_)) bin)
1452        return handle_{haIsBin=bin}
1453
1454 foreign import ccall unsafe "__hscore_setmode"
1455   setmode :: CInt -> Bool -> IO CInt
1456
1457 -- -----------------------------------------------------------------------------
1458 -- Duplicating a Handle
1459
1460 -- |Returns a duplicate of the original handle, with its own buffer
1461 -- and file pointer.  The original handle's buffer is flushed, including
1462 -- discarding any input data, before the handle is duplicated.
1463
1464 hDuplicate :: Handle -> IO Handle
1465 hDuplicate h@(FileHandle path m) = do
1466   new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1467   newFileHandle path (handleFinalizer path) new_h_
1468 hDuplicate h@(DuplexHandle path r w) = do
1469   new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1470   new_w <- newMVar new_w_
1471   new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1472   new_r <- newMVar new_r_
1473   addMVarFinalizer new_w (handleFinalizer path new_w)
1474   return (DuplexHandle path new_r new_w)
1475
1476 dupHandle_ other_side h_ = do
1477   -- flush the buffer first, so we don't have to copy its contents
1478   flushBuffer h_
1479   new_fd <- c_dup (fromIntegral (haFD h_))
1480   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1481   ioref <- newIORef buffer
1482   ioref_buffers <- newIORef BufferListNil
1483
1484   let new_handle_ = h_{ haFD = fromIntegral new_fd,
1485                         haBuffer = ioref,
1486                         haBuffers = ioref_buffers,
1487                         haOtherSide = other_side }
1488   return (h_, new_handle_)
1489
1490 -- -----------------------------------------------------------------------------
1491 -- Replacing a Handle
1492
1493 {- |
1494 Makes the second handle a duplicate of the first handle.  The second
1495 handle will be closed first, if it is not already.
1496
1497 This can be used to retarget the standard Handles, for example:
1498
1499 > do h <- openFile "mystdout" WriteMode
1500 >    hDuplicateTo h stdout
1501 -}
1502
1503 hDuplicateTo :: Handle -> Handle -> IO ()
1504 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1505  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1506    _ <- hClose_help h2_
1507    withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1508 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1509  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1510    _ <- hClose_help w2_
1511    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1512  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1513    _ <- hClose_help r2_
1514    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1515 hDuplicateTo h1 _ =
1516    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1517                 "handles are incompatible" Nothing)
1518
1519 -- ---------------------------------------------------------------------------
1520 -- showing Handles.
1521 --
1522 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1523 -- than the (pure) instance of 'Show' for 'Handle'.
1524
1525 hShow :: Handle -> IO String
1526 hShow h@(FileHandle path _) = showHandle' path False h
1527 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1528
1529 showHandle' filepath is_duplex h =
1530   withHandle_ "showHandle" h $ \hdl_ ->
1531     let
1532      showType | is_duplex = showString "duplex (read-write)"
1533               | otherwise = shows (haType hdl_)
1534     in
1535     return
1536       (( showChar '{' .
1537         showHdl (haType hdl_)
1538             (showString "loc=" . showString filepath . showChar ',' .
1539              showString "type=" . showType . showChar ',' .
1540              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1541              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1542       ) "")
1543    where
1544
1545     showHdl :: HandleType -> ShowS -> ShowS
1546     showHdl ht cont =
1547        case ht of
1548         ClosedHandle  -> shows ht . showString "}"
1549         _ -> cont
1550
1551     showBufMode :: Buffer -> BufferMode -> ShowS
1552     showBufMode buf bmo =
1553       case bmo of
1554         NoBuffering   -> showString "none"
1555         LineBuffering -> showString "line"
1556         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1557         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1558       where
1559        def :: Int
1560        def = bufSize buf
1561
1562 -- ---------------------------------------------------------------------------
1563 -- debugging
1564
1565 #ifdef DEBUG_DUMP
1566 puts :: String -> IO ()
1567 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1568                                      return ()
1569 #endif
1570
1571 -- -----------------------------------------------------------------------------
1572 -- utils
1573
1574 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
1575 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
1576   do
1577     res <- f
1578     if (res :: CInt) == -1
1579       then do
1580         err <- getErrno
1581         if err == eINTR
1582           then throwErrnoIfMinus1RetryOnBlock loc f on_block
1583           else if err == eWOULDBLOCK || err == eAGAIN
1584                  then do on_block
1585                  else throwErrno loc
1586       else return res
1587
1588 -- -----------------------------------------------------------------------------
1589 -- wrappers to platform-specific constants:
1590
1591 foreign import ccall unsafe "__hscore_supportsTextMode"
1592   tEXT_MODE_SEEK_ALLOWED :: Bool
1593
1594 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1595 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1596 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1597 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt