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