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