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