GHC/Handle.hs

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