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