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