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