GHC/Handle.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
   2
   3 #undef DEBUG_DUMP
   4 #undef DEBUG
   5
   6 -----------------------------------------------------------------------------
   7 -- |
   8 -- Module      :  GHC.Handle
   9 -- Copyright   :  (c) The University of Glasgow, 1994-2001
  10 -- License     :  see libraries/base/LICENSE
  11 --
  12 -- Maintainer  :  libraries@haskell.org
  13 -- Stability   :  internal
  14 -- Portability :  non-portable
  15 --
  16 -- This module defines the basic operations on I\/O \"handles\".
  17 --
  18 -----------------------------------------------------------------------------
  19
  20 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 #ifdef mingw32_TARGET_OS
 791                   WriteMode     -> write_flags .|. o_TRUNC
 792 #else
 793                   WriteMode     -> write_flags
 794 #endif
 795                   ReadWriteMode -> rw_flags
 796                   AppendMode    -> append_flags
 797
 798       binary_flags
 799           | binary    = o_BINARY
 800           | otherwise = 0
 801
 802       oflags = oflags1 .|. binary_flags
 803     in do
 804
 805     -- the old implementation had a complicated series of three opens,
 806     -- which is perhaps because we have to be careful not to open
 807     -- directories.  However, the man pages I've read say that open()
 808     -- always returns EISDIR if the file is a directory and was opened
 809     -- for writing, so I think we're ok with a single open() here...
 810     fd <- fromIntegral `liftM`
 811               throwErrnoIfMinus1Retry "openFile"
 812                 (c_open f (fromIntegral oflags) 0o666)
 813
 814     h <- openFd fd Nothing False filepath mode binary
 815             `catchException` \e -> do c_close (fromIntegral fd); throw e
 816         -- NB. don't forget to close the FD if openFd fails, otherwise
 817         -- this FD leaks.
 818         -- ASSERT: if we just created the file, then openFd won't fail
 819         -- (so we don't need to worry about removing the newly created file
 820         --  in the event of an error).
 821 #ifndef mingw32_TARGET_OS
 822     if mode == WriteMode
 823       then throwErrnoIf (/=0) "openFile"
 824               (c_ftruncate (fromIntegral fd) 0)
 825       else return 0
 826 #endif
 827     return h
 828
 829
 830 -- | The function creates a temporary file in ReadWrite mode.
 831 -- The created file isn\'t deleted automatically, so you need to delete it manually.
 832 openTempFile :: FilePath   -- ^ Directory in which to create the file
 833              -> String     -- ^ File name template. If the template is \"foo.ext\" then
 834                            -- the create file will be \"fooXXX.ext\" where XXX is some
 835                            -- random number.
 836              -> IO (FilePath, Handle)
 837 openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
 838
 839 -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
 840 openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
 841 openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
 842
 843 openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
 844 openTempFile' loc tmp_dir template binary = do
 845   pid <- c_getpid
 846   findTempName pid
 847   where
 848     (prefix,suffix) = break (=='.') template
 849
 850     oflags1 = rw_flags .|. o_EXCL
 851
 852     binary_flags
 853       | binary    = o_BINARY
 854       | otherwise = 0
 855
 856     oflags = oflags1 .|. binary_flags
 857
 858     findTempName x = do
 859       fd <- withCString filepath $ \ f ->
 860               c_open f oflags 0o666
 861       if fd < 0
 862        then do
 863          errno <- getErrno
 864          if errno == eEXIST
 865            then findTempName (x+1)
 866            else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
 867        else do
 868          h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True
 869                 `catchException` \e -> do c_close (fromIntegral fd); throw e
 870          return (filepath, h)
 871       where
 872         filename        = prefix ++ show x ++ suffix
 873         filepath        = tmp_dir `joinFileName` filename
 874
 875
 876 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 877 output_flags = std_flags    .|. o_CREAT
 878 read_flags   = std_flags    .|. o_RDONLY
 879 write_flags  = output_flags .|. o_WRONLY
 880 rw_flags     = output_flags .|. o_RDWR
 881 append_flags = write_flags  .|. o_APPEND
 882
 883 -- ---------------------------------------------------------------------------
 884 -- openFd
 885
 886 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
 887 openFd fd mb_fd_type is_socket filepath mode binary = do
 888     -- turn on non-blocking mode
 889     setNonBlockingFD fd
 890
 891     let (ha_type, write) =
 892           case mode of
 893             ReadMode      -> ( ReadHandle,      False )
 894             WriteMode     -> ( WriteHandle,     True )
 895             ReadWriteMode -> ( ReadWriteHandle, True )
 896             AppendMode    -> ( AppendHandle,    True )
 897
 898     -- open() won't tell us if it was a directory if we only opened for
 899     -- reading, so check again.
 900     fd_type <-
 901       case mb_fd_type of
 902         Just x  -> return x
 903         Nothing -> fdType fd
 904
 905     case fd_type of
 906         Directory ->
 907            ioException (IOError Nothing InappropriateType "openFile"
 908                            "is a directory" Nothing)
 909
 910         Stream
 911            | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
 912            | otherwise                  -> mkFileHandle fd is_socket filepath ha_type binary
 913
 914         -- regular files need to be locked
 915         RegularFile -> do
 916 #ifndef mingw32_TARGET_OS
 917            r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 918            when (r == -1)  $
 919                 ioException (IOError Nothing ResourceBusy "openFile"
 920                                    "file is locked" Nothing)
 921 #endif
 922            mkFileHandle fd is_socket filepath ha_type binary
 923
 924
 925 fdToHandle :: FD -> IO Handle
 926 fdToHandle fd = do
 927    mode <- fdGetMode fd
 928    let fd_str = "<file descriptor: " ++ show fd ++ ">"
 929    openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
 930
 931
 932 #ifndef mingw32_TARGET_OS
 933 foreign import ccall unsafe "lockFile"
 934   lockFile :: CInt -> CInt -> CInt -> IO CInt
 935
 936 foreign import ccall unsafe "unlockFile"
 937   unlockFile :: CInt -> IO CInt
 938 #endif
 939
 940 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
 941         -> IO Handle
 942 mkStdHandle fd filepath ha_type buf bmode = do
 943    spares <- newIORef BufferListNil
 944    newFileHandle filepath (stdHandleFinalizer filepath)
 945             (Handle__ { haFD = fd,
 946                         haType = ha_type,
 947                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
 948                         haIsStream = False,
 949                         haBufferMode = bmode,
 950                         haBuffer = buf,
 951                         haBuffers = spares,
 952                         haOtherSide = Nothing
 953                       })
 954
 955 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 956 mkFileHandle fd is_stream filepath ha_type binary = do
 957   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 958   spares <- newIORef BufferListNil
 959   newFileHandle filepath (handleFinalizer filepath)
 960             (Handle__ { haFD = fd,
 961                         haType = ha_type,
 962                         haIsBin = binary,
 963                         haIsStream = is_stream,
 964                         haBufferMode = bmode,
 965                         haBuffer = buf,
 966                         haBuffers = spares,
 967                         haOtherSide = Nothing
 968                       })
 969
 970 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
 971 mkDuplexHandle fd is_stream filepath binary = do
 972   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 973   w_spares <- newIORef BufferListNil
 974   let w_handle_ =
 975              Handle__ { haFD = fd,
 976                         haType = WriteHandle,
 977                         haIsBin = binary,
 978                         haIsStream = is_stream,
 979                         haBufferMode = w_bmode,
 980                         haBuffer = w_buf,
 981                         haBuffers = w_spares,
 982                         haOtherSide = Nothing
 983                       }
 984   write_side <- newMVar w_handle_
 985
 986   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 987   r_spares <- newIORef BufferListNil
 988   let r_handle_ =
 989              Handle__ { haFD = fd,
 990                         haType = ReadHandle,
 991                         haIsBin = binary,
 992                         haIsStream = is_stream,
 993                         haBufferMode = r_bmode,
 994                         haBuffer = r_buf,
 995                         haBuffers = r_spares,
 996                         haOtherSide = Just write_side
 997                       }
 998   read_side <- newMVar r_handle_
 999
1000   addMVarFinalizer write_side (handleFinalizer filepath write_side)
1001   return (DuplexHandle filepath read_side write_side)
1002
1003
1004 initBufferState ReadHandle = ReadBuffer
1005 initBufferState _          = WriteBuffer
1006
1007 -- ---------------------------------------------------------------------------
1008 -- Closing a handle
1009
1010 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
1011 -- computation finishes, if @hdl@ is writable its buffer is flushed as
1012 -- for 'hFlush'.
1013 -- Performing 'hClose' on a handle that has already been closed has no effect;
1014 -- doing so not an error.  All other operations on a closed handle will fail.
1015 -- If 'hClose' fails for any reason, any further operations (apart from
1016 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
1017 -- closed.
1018
1019 hClose :: Handle -> IO ()
1020 hClose h@(FileHandle _ m)     = hClose' h m
1021 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
1022
1023 hClose' h m = withHandle__' "hClose" h m $ hClose_help
1024
1025 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
1026 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
1027 -- then closed immediately.  We have to be careful with DuplexHandles
1028 -- though: we have to leave the closing to the finalizer in that case,
1029 -- because the write side may still be in use.
1030 hClose_help :: Handle__ -> IO Handle__
1031 hClose_help handle_ =
1032   case haType handle_ of
1033       ClosedHandle -> return handle_
1034       _ -> do flushWriteBufferOnly handle_ -- interruptible
1035               hClose_handle_ handle_
1036
1037 hClose_handle_ handle_ = do
1038     let fd = haFD handle_
1039         c_fd = fromIntegral fd
1040
1041     -- close the file descriptor, but not when this is the read
1042     -- side of a duplex handle.
1043     case haOtherSide handle_ of
1044       Nothing ->
1045                   throwErrnoIfMinus1Retry_ "hClose"
1046 #ifdef mingw32_TARGET_OS
1047                                 (closeFd (haIsStream handle_) c_fd)
1048 #else
1049                                 (c_close c_fd)
1050 #endif
1051       Just _  -> return ()
1052
1053     -- free the spare buffers
1054     writeIORef (haBuffers handle_) BufferListNil
1055
1056 #ifndef mingw32_TARGET_OS
1057     -- unlock it
1058     unlockFile c_fd
1059 #endif
1060
1061     -- we must set the fd to -1, because the finalizer is going
1062     -- to run eventually and try to close/unlock it.
1063     return (handle_{ haFD        = -1,
1064                      haType      = ClosedHandle
1065                    })
1066
1067 -----------------------------------------------------------------------------
1068 -- Detecting and changing the size of a file
1069
1070 -- | For a handle @hdl@ which attached to a physical file,
1071 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1072
1073 hFileSize :: Handle -> IO Integer
1074 hFileSize handle =
1075     withHandle_ "hFileSize" handle $ \ handle_ -> do
1076     case haType handle_ of
1077       ClosedHandle              -> ioe_closedHandle
1078       SemiClosedHandle          -> ioe_closedHandle
1079       _ -> do flushWriteBufferOnly handle_
1080               r <- fdFileSize (haFD handle_)
1081               if r /= -1
1082                  then return r
1083                  else ioException (IOError Nothing InappropriateType "hFileSize"
1084                                    "not a regular file" Nothing)
1085
1086
1087 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1088
1089 hSetFileSize :: Handle -> Integer -> IO ()
1090 hSetFileSize handle size =
1091     withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1092     case haType handle_ of
1093       ClosedHandle              -> ioe_closedHandle
1094       SemiClosedHandle          -> ioe_closedHandle
1095       _ -> do flushWriteBufferOnly handle_
1096               throwErrnoIf (/=0) "hSetFileSize"
1097                  (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
1098               return ()
1099
1100 -- ---------------------------------------------------------------------------
1101 -- Detecting the End of Input
1102
1103 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1104 -- 'True' if no further input can be taken from @hdl@ or for a
1105 -- physical file, if the current I\/O position is equal to the length of
1106 -- the file.  Otherwise, it returns 'False'.
1107
1108 hIsEOF :: Handle -> IO Bool
1109 hIsEOF handle =
1110   catch
1111      (do hLookAhead handle; return False)
1112      (\e -> if isEOFError e then return True else ioError e)
1113
1114 -- | The computation 'isEOF' is identical to 'hIsEOF',
1115 -- except that it works only on 'stdin'.
1116
1117 isEOF :: IO Bool
1118 isEOF = hIsEOF stdin
1119
1120 -- ---------------------------------------------------------------------------
1121 -- Looking ahead
1122
1123 -- | Computation 'hLookAhead' returns the next character from the handle
1124 -- without removing it from the input buffer, blocking until a character
1125 -- is available.
1126 --
1127 -- This operation may fail with:
1128 --
1129 --  * 'isEOFError' if the end of file has been reached.
1130
1131 hLookAhead :: Handle -> IO Char
1132 hLookAhead handle = do
1133   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
1134   let ref     = haBuffer handle_
1135       fd      = haFD handle_
1136       is_line = haBufferMode handle_ == LineBuffering
1137   buf <- readIORef ref
1138
1139   -- fill up the read buffer if necessary
1140   new_buf <- if bufferEmpty buf
1141                 then fillReadBuffer fd is_line (haIsStream handle_) buf
1142                 else return buf
1143
1144   writeIORef ref new_buf
1145
1146   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1147   return c
1148
1149 -- ---------------------------------------------------------------------------
1150 -- Buffering Operations
1151
1152 -- Three kinds of buffering are supported: line-buffering,
1153 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
1154 -- further explanation of what the type represent.
1155
1156 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1157 -- handle @hdl@ on subsequent reads and writes.
1158 --
1159 -- If the buffer mode is changed from 'BlockBuffering' or
1160 -- 'LineBuffering' to 'NoBuffering', then
1161 --
1162 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1163 --
1164 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
1165 --
1166 -- This operation may fail with:
1167 --
1168 --  * 'isPermissionError' if the handle has already been used for reading
1169 --    or writing and the implementation does not allow the buffering mode
1170 --    to be changed.
1171
1172 hSetBuffering :: Handle -> BufferMode -> IO ()
1173 hSetBuffering handle mode =
1174   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1175   case haType handle_ of
1176     ClosedHandle -> ioe_closedHandle
1177     _ -> do
1178          {- Note:
1179             - we flush the old buffer regardless of whether
1180               the new buffer could fit the contents of the old buffer
1181               or not.
1182             - allow a handle's buffering to change even if IO has
1183               occurred (ANSI C spec. does not allow this, nor did
1184               the previous implementation of IO.hSetBuffering).
1185             - a non-standard extension is to allow the buffering
1186               of semi-closed handles to change [sof 6/98]
1187           -}
1188           flushBuffer handle_
1189
1190           let state = initBufferState (haType handle_)
1191           new_buf <-
1192             case mode of
1193                 -- we always have a 1-character read buffer for
1194                 -- unbuffered  handles: it's needed to
1195                 -- support hLookAhead.
1196               NoBuffering            -> allocateBuffer 1 ReadBuffer
1197               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1198               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1199               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1200                                       | otherwise -> allocateBuffer n state
1201           writeIORef (haBuffer handle_) new_buf
1202
1203           -- for input terminals we need to put the terminal into
1204           -- cooked or raw mode depending on the type of buffering.
1205           is_tty <- fdIsTTY (haFD handle_)
1206           when (is_tty && isReadableHandleType (haType handle_)) $
1207                 case mode of
1208 #ifndef mingw32_TARGET_OS
1209         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1210         -- for most common uses), so simply disable its use here.
1211                   NoBuffering -> setCooked (haFD handle_) False
1212 #endif
1213                   _           -> setCooked (haFD handle_) True
1214
1215           -- throw away spare buffers, they might be the wrong size
1216           writeIORef (haBuffers handle_) BufferListNil
1217
1218           return (handle_{ haBufferMode = mode })
1219
1220 -- -----------------------------------------------------------------------------
1221 -- hFlush
1222
1223 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1224 -- in handle @hdl@ to be sent immediately to the operating system.
1225 --
1226 -- This operation may fail with:
1227 --
1228 --  * 'isFullError' if the device is full;
1229 --
1230 --  * 'isPermissionError' if a system resource limit would be exceeded.
1231 --    It is unspecified whether the characters in the buffer are discarded
1232 --    or retained under these circumstances.
1233
1234 hFlush :: Handle -> IO ()
1235 hFlush handle =
1236    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1237    buf <- readIORef (haBuffer handle_)
1238    if bufferIsWritable buf && not (bufferEmpty buf)
1239         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1240                 writeIORef (haBuffer handle_) flushed_buf
1241         else return ()
1242
1243
1244 -- -----------------------------------------------------------------------------
1245 -- Repositioning Handles
1246
1247 data HandlePosn = HandlePosn Handle HandlePosition
1248
1249 instance Eq HandlePosn where
1250     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1251
1252 instance Show HandlePosn where
1253    showsPrec p (HandlePosn h pos) =
1254         showsPrec p h . showString " at position " . shows pos
1255
1256   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1257   -- We represent it as an Integer on the Haskell side, but
1258   -- cheat slightly in that hGetPosn calls upon a C helper
1259   -- that reports the position back via (merely) an Int.
1260 type HandlePosition = Integer
1261
1262 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1263 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1264
1265 hGetPosn :: Handle -> IO HandlePosn
1266 hGetPosn handle = do
1267     posn <- hTell handle
1268     return (HandlePosn handle posn)
1269
1270 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1271 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1272 -- to the position it held at the time of the call to 'hGetPosn'.
1273 --
1274 -- This operation may fail with:
1275 --
1276 --  * 'isPermissionError' if a system resource limit would be exceeded.
1277
1278 hSetPosn :: HandlePosn -> IO ()
1279 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1280
1281 -- ---------------------------------------------------------------------------
1282 -- hSeek
1283
1284 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1285 data SeekMode
1286   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1287   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1288                         -- from the current position.
1289   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1290                         -- from the end of the file.
1291     deriving (Eq, Ord, Ix, Enum, Read, Show)
1292
1293 {- Note:
1294  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1295    seeking at or past EOF.
1296
1297  - we possibly deviate from the report on the issue of seeking within
1298    the buffer and whether to flush it or not.  The report isn't exactly
1299    clear here.
1300 -}
1301
1302 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1303 -- @hdl@ depending on @mode@.
1304 -- The offset @i@ is given in terms of 8-bit bytes.
1305 --
1306 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1307 -- in the current buffer will first cause any items in the output buffer to be
1308 -- written to the device, and then cause the input buffer to be discarded.
1309 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1310 -- subset of the possible positioning operations (for instance, it may only
1311 -- be possible to seek to the end of a tape, or to a positive offset from
1312 -- the beginning or current position).
1313 -- It is not possible to set a negative I\/O position, or for
1314 -- a physical file, an I\/O position beyond the current end-of-file.
1315 --
1316 -- This operation may fail with:
1317 --
1318 --  * 'isPermissionError' if a system resource limit would be exceeded.
1319
1320 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1321 hSeek handle mode offset =
1322     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1323 #   ifdef DEBUG_DUMP
1324     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1325 #   endif
1326     let ref = haBuffer handle_
1327     buf <- readIORef ref
1328     let r = bufRPtr buf
1329         w = bufWPtr buf
1330         fd = haFD handle_
1331
1332     let do_seek =
1333           throwErrnoIfMinus1Retry_ "hSeek"
1334             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1335
1336         whence :: CInt
1337         whence = case mode of
1338                    AbsoluteSeek -> sEEK_SET
1339                    RelativeSeek -> sEEK_CUR
1340                    SeekFromEnd  -> sEEK_END
1341
1342     if bufferIsWritable buf
1343         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1344                 writeIORef ref new_buf
1345                 do_seek
1346         else do
1347
1348     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1349         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1350         else do
1351
1352     new_buf <- flushReadBuffer (haFD handle_) buf
1353     writeIORef ref new_buf
1354     do_seek
1355
1356
1357 hTell :: Handle -> IO Integer
1358 hTell handle =
1359     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1360
1361 #if defined(mingw32_TARGET_OS)
1362         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1363         -- so we can't easily calculate the file position using the
1364         -- current buffer size.  Just flush instead.
1365       flushBuffer handle_
1366 #endif
1367       let fd = fromIntegral (haFD handle_)
1368       posn <- fromIntegral `liftM`
1369                 throwErrnoIfMinus1Retry "hGetPosn"
1370                    (c_lseek fd 0 sEEK_CUR)
1371
1372       let ref = haBuffer handle_
1373       buf <- readIORef ref
1374
1375       let real_posn
1376            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1377            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1378 #     ifdef DEBUG_DUMP
1379       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1380       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1381 #     endif
1382       return real_posn
1383
1384 -- -----------------------------------------------------------------------------
1385 -- Handle Properties
1386
1387 -- A number of operations return information about the properties of a
1388 -- handle.  Each of these operations returns `True' if the handle has
1389 -- the specified property, and `False' otherwise.
1390
1391 hIsOpen :: Handle -> IO Bool
1392 hIsOpen handle =
1393     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1394     case haType handle_ of
1395       ClosedHandle         -> return False
1396       SemiClosedHandle     -> return False
1397       _                    -> return True
1398
1399 hIsClosed :: Handle -> IO Bool
1400 hIsClosed handle =
1401     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1402     case haType handle_ of
1403       ClosedHandle         -> return True
1404       _                    -> return False
1405
1406 {- not defined, nor exported, but mentioned
1407    here for documentation purposes:
1408
1409     hSemiClosed :: Handle -> IO Bool
1410     hSemiClosed h = do
1411        ho <- hIsOpen h
1412        hc <- hIsClosed h
1413        return (not (ho || hc))
1414 -}
1415
1416 hIsReadable :: Handle -> IO Bool
1417 hIsReadable (DuplexHandle _ _ _) = return True
1418 hIsReadable handle =
1419     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1420     case haType handle_ of
1421       ClosedHandle         -> ioe_closedHandle
1422       SemiClosedHandle     -> ioe_closedHandle
1423       htype                -> return (isReadableHandleType htype)
1424
1425 hIsWritable :: Handle -> IO Bool
1426 hIsWritable (DuplexHandle _ _ _) = return True
1427 hIsWritable handle =
1428     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1429     case haType handle_ of
1430       ClosedHandle         -> ioe_closedHandle
1431       SemiClosedHandle     -> ioe_closedHandle
1432       htype                -> return (isWritableHandleType htype)
1433
1434 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1435 -- for @hdl@.
1436
1437 hGetBuffering :: Handle -> IO BufferMode
1438 hGetBuffering handle =
1439     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1440     case haType handle_ of
1441       ClosedHandle         -> ioe_closedHandle
1442       _ ->
1443            -- We're being non-standard here, and allow the buffering
1444            -- of a semi-closed handle to be queried.   -- sof 6/98
1445           return (haBufferMode handle_)  -- could be stricter..
1446
1447 hIsSeekable :: Handle -> IO Bool
1448 hIsSeekable handle =
1449     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1450     case haType handle_ of
1451       ClosedHandle         -> ioe_closedHandle
1452       SemiClosedHandle     -> ioe_closedHandle
1453       AppendHandle         -> return False
1454       _                    -> do t <- fdType (haFD handle_)
1455                                  return (t == RegularFile
1456                                          && (haIsBin handle_
1457                                                 || tEXT_MODE_SEEK_ALLOWED))
1458
1459 -- -----------------------------------------------------------------------------
1460 -- Changing echo status (Non-standard GHC extensions)
1461
1462 -- | Set the echoing status of a handle connected to a terminal.
1463
1464 hSetEcho :: Handle -> Bool -> IO ()
1465 hSetEcho handle on = do
1466     isT   <- hIsTerminalDevice handle
1467     if not isT
1468      then return ()
1469      else
1470       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1471       case haType handle_ of
1472          ClosedHandle -> ioe_closedHandle
1473          _            -> setEcho (haFD handle_) on
1474
1475 -- | Get the echoing status of a handle connected to a terminal.
1476
1477 hGetEcho :: Handle -> IO Bool
1478 hGetEcho handle = do
1479     isT   <- hIsTerminalDevice handle
1480     if not isT
1481      then return False
1482      else
1483        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1484        case haType handle_ of
1485          ClosedHandle -> ioe_closedHandle
1486          _            -> getEcho (haFD handle_)
1487
1488 -- | Is the handle connected to a terminal?
1489
1490 hIsTerminalDevice :: Handle -> IO Bool
1491 hIsTerminalDevice handle = do
1492     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1493      case haType handle_ of
1494        ClosedHandle -> ioe_closedHandle
1495        _            -> fdIsTTY (haFD handle_)
1496
1497 -- -----------------------------------------------------------------------------
1498 -- hSetBinaryMode
1499
1500 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1501 -- (See also 'openBinaryFile'.)
1502
1503 hSetBinaryMode :: Handle -> Bool -> IO ()
1504 hSetBinaryMode handle bin =
1505   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1506     do throwErrnoIfMinus1_ "hSetBinaryMode"
1507           (setmode (fromIntegral (haFD handle_)) bin)
1508        return handle_{haIsBin=bin}
1509
1510 foreign import ccall unsafe "__hscore_setmode"
1511   setmode :: CInt -> Bool -> IO CInt
1512
1513 -- -----------------------------------------------------------------------------
1514 -- Duplicating a Handle
1515
1516 -- |Returns a duplicate of the original handle, with its own buffer
1517 -- and file pointer.  The original handle's buffer is flushed, including
1518 -- discarding any input data, before the handle is duplicated.
1519
1520 hDuplicate :: Handle -> IO Handle
1521 hDuplicate h@(FileHandle path m) = do
1522   new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1523   newFileHandle path (handleFinalizer path) new_h_
1524 hDuplicate h@(DuplexHandle path r w) = do
1525   new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1526   new_w <- newMVar new_w_
1527   new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1528   new_r <- newMVar new_r_
1529   addMVarFinalizer new_w (handleFinalizer path new_w)
1530   return (DuplexHandle path new_r new_w)
1531
1532 dupHandle_ other_side h_ = do
1533   -- flush the buffer first, so we don't have to copy its contents
1534   flushBuffer h_
1535   new_fd <- c_dup (fromIntegral (haFD h_))
1536   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1537   ioref <- newIORef buffer
1538   ioref_buffers <- newIORef BufferListNil
1539
1540   let new_handle_ = h_{ haFD = fromIntegral new_fd,
1541                         haBuffer = ioref,
1542                         haBuffers = ioref_buffers,
1543                         haOtherSide = other_side }
1544   return (h_, new_handle_)
1545
1546 -- -----------------------------------------------------------------------------
1547 -- Replacing a Handle
1548
1549 {- |
1550 Makes the second handle a duplicate of the first handle.  The second
1551 handle will be closed first, if it is not already.
1552
1553 This can be used to retarget the standard Handles, for example:
1554
1555 > do h <- openFile "mystdout" WriteMode
1556 >    hDuplicateTo h stdout
1557 -}
1558
1559 hDuplicateTo :: Handle -> Handle -> IO ()
1560 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1561  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1562    _ <- hClose_help h2_
1563    withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1564 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1565  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1566    _ <- hClose_help w2_
1567    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1568  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1569    _ <- hClose_help r2_
1570    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1571 hDuplicateTo h1 _ =
1572    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1573                 "handles are incompatible" Nothing)
1574
1575 -- ---------------------------------------------------------------------------
1576 -- showing Handles.
1577 --
1578 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1579 -- than the (pure) instance of 'Show' for 'Handle'.
1580
1581 hShow :: Handle -> IO String
1582 hShow h@(FileHandle path _) = showHandle' path False h
1583 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1584
1585 showHandle' filepath is_duplex h =
1586   withHandle_ "showHandle" h $ \hdl_ ->
1587     let
1588      showType | is_duplex = showString "duplex (read-write)"
1589               | otherwise = shows (haType hdl_)
1590     in
1591     return
1592       (( showChar '{' .
1593         showHdl (haType hdl_)
1594             (showString "loc=" . showString filepath . showChar ',' .
1595              showString "type=" . showType . showChar ',' .
1596              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1597              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1598       ) "")
1599    where
1600
1601     showHdl :: HandleType -> ShowS -> ShowS
1602     showHdl ht cont =
1603        case ht of
1604         ClosedHandle  -> shows ht . showString "}"
1605         _ -> cont
1606
1607     showBufMode :: Buffer -> BufferMode -> ShowS
1608     showBufMode buf bmo =
1609       case bmo of
1610         NoBuffering   -> showString "none"
1611         LineBuffering -> showString "line"
1612         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1613         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1614       where
1615        def :: Int
1616        def = bufSize buf
1617
1618 -- ---------------------------------------------------------------------------
1619 -- debugging
1620
1621 #ifdef DEBUG_DUMP
1622 puts :: String -> IO ()
1623 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1624                                      return ()
1625 #endif
1626
1627 -- -----------------------------------------------------------------------------
1628 -- utils
1629
1630 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
1631 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
1632   do
1633     res <- f
1634     if (res :: CInt) == -1
1635       then do
1636         err <- getErrno
1637         if err == eINTR
1638           then throwErrnoIfMinus1RetryOnBlock loc f on_block
1639           else if err == eWOULDBLOCK || err == eAGAIN
1640                  then do on_block
1641                  else throwErrno loc
1642       else return res
1643
1644 -- -----------------------------------------------------------------------------
1645 -- wrappers to platform-specific constants:
1646
1647 foreign import ccall unsafe "__hscore_supportsTextMode"
1648   tEXT_MODE_SEEK_ALLOWED :: Bool
1649
1650 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1651 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1652 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1653 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt