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