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