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   HandlePosition, 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 -- | A handle managing input from the Haskell program's standard input channel.
 594 stdin :: Handle
 595 stdin = unsafePerformIO $ do
 596    -- ToDo: acquire lock
 597    setNonBlockingFD fd_stdin
 598    (buf, bmode) <- getBuffer fd_stdin ReadBuffer
 599    mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
 600
 601 -- | A handle managing output to the Haskell program's standard output channel.
 602 stdout :: Handle
 603 stdout = unsafePerformIO $ do
 604    -- ToDo: acquire lock
 605    -- We don't set non-blocking mode on stdout or sterr, because
 606    -- some shells don't recover properly.
 607    -- setNonBlockingFD fd_stdout
 608    (buf, bmode) <- getBuffer fd_stdout WriteBuffer
 609    mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
 610
 611 -- | A handle managing output to the Haskell program's standard error channel.
 612 stderr :: Handle
 613 stderr = unsafePerformIO $ do
 614     -- ToDo: acquire lock
 615    -- We don't set non-blocking mode on stdout or sterr, because
 616    -- some shells don't recover properly.
 617    -- setNonBlockingFD fd_stderr
 618    buf <- mkUnBuffer
 619    mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
 620
 621 -- ---------------------------------------------------------------------------
 622 -- Opening and Closing Files
 623
 624 addFilePathToIOError fun fp (IOError h iot _ str _)
 625   = IOError h iot fun str (Just fp)
 626
 627 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
 628 -- handle to manage the file @file@.  It manages input if @mode@
 629 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
 630 -- and both input and output if mode is 'ReadWriteMode'.
 631 --
 632 -- If the file does not exist and it is opened for output, it should be
 633 -- created as a new file.  If @mode@ is 'WriteMode' and the file
 634 -- already exists, then it should be truncated to zero length.
 635 -- Some operating systems delete empty files, so there is no guarantee
 636 -- that the file will exist following an 'openFile' with @mode@
 637 -- 'WriteMode' unless it is subsequently written to successfully.
 638 -- The handle is positioned at the end of the file if @mode@ is
 639 -- 'AppendMode', and otherwise at the beginning (in which case its
 640 -- internal position is 0).
 641 -- The initial buffer mode is implementation-dependent.
 642 --
 643 -- This operation may fail with:
 644 --
 645 --  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
 646 --
 647 --  * 'isDoesNotExistError' if the file does not exist; or
 648 --
 649 --  * 'isPermissionError' if the user does not have permission to open the file.
 650
 651 openFile :: FilePath -> IOMode -> IO Handle
 652 openFile fp im =
 653   catch
 654     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
 655     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 656
 657 -- | Like 'openFile', but open the file in binary mode.
 658 -- On Windows, reading a file in text mode (which is the default)
 659 -- will translate CRLF to LF, and writing will translate LF to CRLF.
 660 -- This is usually what you want with text files.  With binary files
 661 -- this is undesirable; also, as usual under Microsoft operating systems,
 662 -- text mode treats control-Z as EOF.  Binary mode turns off all special
 663 -- treatment of end-of-line and end-of-file characters.
 664 -- (See also 'hSetBinaryMode'.)
 665
 666 openBinaryFile :: FilePath -> IOMode -> IO Handle
 667 openBinaryFile fp m =
 668   catch
 669     (openFile' fp m True)
 670     (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
 671
 672 openFile' filepath mode binary =
 673   withCString filepath $ \ f ->
 674
 675     let
 676       oflags1 = case mode of
 677                   ReadMode      -> read_flags
 678                   WriteMode     -> write_flags
 679                   ReadWriteMode -> rw_flags
 680                   AppendMode    -> append_flags
 681
 682       truncate | WriteMode <- mode = True
 683                | otherwise         = False
 684
 685       binary_flags
 686           | binary    = o_BINARY
 687           | otherwise = 0
 688
 689       oflags = oflags1 .|. binary_flags
 690     in do
 691
 692     -- the old implementation had a complicated series of three opens,
 693     -- which is perhaps because we have to be careful not to open
 694     -- directories.  However, the man pages I've read say that open()
 695     -- always returns EISDIR if the file is a directory and was opened
 696     -- for writing, so I think we're ok with a single open() here...
 697     fd <- fromIntegral `liftM`
 698               throwErrnoIfMinus1Retry "openFile"
 699                 (c_open f (fromIntegral oflags) 0o666)
 700
 701     openFd fd Nothing filepath mode binary truncate
 702         -- ASSERT: if we just created the file, then openFd won't fail
 703         -- (so we don't need to worry about removing the newly created file
 704         --  in the event of an error).
 705
 706
 707 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 708 output_flags = std_flags    .|. o_CREAT
 709 read_flags   = std_flags    .|. o_RDONLY
 710 write_flags  = output_flags .|. o_WRONLY
 711 rw_flags     = output_flags .|. o_RDWR
 712 append_flags = write_flags  .|. o_APPEND
 713
 714 -- ---------------------------------------------------------------------------
 715 -- openFd
 716
 717 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
 718 openFd fd mb_fd_type filepath mode binary truncate = do
 719     -- turn on non-blocking mode
 720     setNonBlockingFD fd
 721
 722     let (ha_type, write) =
 723           case mode of
 724             ReadMode      -> ( ReadHandle,      False )
 725             WriteMode     -> ( WriteHandle,     True )
 726             ReadWriteMode -> ( ReadWriteHandle, True )
 727             AppendMode    -> ( AppendHandle,    True )
 728
 729     -- open() won't tell us if it was a directory if we only opened for
 730     -- reading, so check again.
 731     fd_type <-
 732       case mb_fd_type of
 733         Just x  -> return x
 734         Nothing -> fdType fd
 735     let is_stream = fd_type == Stream
 736     case fd_type of
 737         Directory ->
 738            ioException (IOError Nothing InappropriateType "openFile"
 739                            "is a directory" Nothing)
 740
 741         Stream
 742            | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
 743            | otherwise                  -> mkFileHandle fd is_stream filepath ha_type binary
 744
 745         -- regular files need to be locked
 746         RegularFile -> do
 747            r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 748            when (r == -1)  $
 749                 ioException (IOError Nothing ResourceBusy "openFile"
 750                                    "file is locked" Nothing)
 751
 752            -- truncate the file if necessary
 753            when truncate (fileTruncate filepath)
 754
 755            mkFileHandle fd is_stream filepath ha_type binary
 756
 757
 758 fdToHandle :: FD -> IO Handle
 759 fdToHandle fd = do
 760    mode <- fdGetMode fd
 761    let fd_str = "<file descriptor: " ++ show fd ++ ">"
 762    openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
 763
 764 foreign import ccall unsafe "lockFile"
 765   lockFile :: CInt -> CInt -> CInt -> IO CInt
 766
 767 foreign import ccall unsafe "unlockFile"
 768   unlockFile :: CInt -> IO CInt
 769
 770 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
 771         -> IO Handle
 772 mkStdHandle fd filepath ha_type buf bmode = do
 773    spares <- newIORef BufferListNil
 774    newFileHandle filepath stdHandleFinalizer
 775             (Handle__ { haFD = fd,
 776                         haType = ha_type,
 777                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
 778                         haIsStream = False,
 779                         haBufferMode = bmode,
 780                         haBuffer = buf,
 781                         haBuffers = spares,
 782                         haOtherSide = Nothing
 783                       })
 784
 785 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 786 mkFileHandle fd is_stream filepath ha_type binary = do
 787   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 788   spares <- newIORef BufferListNil
 789   newFileHandle filepath handleFinalizer
 790             (Handle__ { haFD = fd,
 791                         haType = ha_type,
 792                         haIsBin = binary,
 793                         haIsStream = is_stream,
 794                         haBufferMode = bmode,
 795                         haBuffer = buf,
 796                         haBuffers = spares,
 797                         haOtherSide = Nothing
 798                       })
 799
 800 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
 801 mkDuplexHandle fd is_stream filepath binary = do
 802   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 803   w_spares <- newIORef BufferListNil
 804   let w_handle_ =
 805              Handle__ { haFD = fd,
 806                         haType = WriteHandle,
 807                         haIsBin = binary,
 808                         haIsStream = is_stream,
 809                         haBufferMode = w_bmode,
 810                         haBuffer = w_buf,
 811                         haBuffers = w_spares,
 812                         haOtherSide = Nothing
 813                       }
 814   write_side <- newMVar w_handle_
 815
 816   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 817   r_spares <- newIORef BufferListNil
 818   let r_handle_ =
 819              Handle__ { haFD = fd,
 820                         haType = ReadHandle,
 821                         haIsBin = binary,
 822                         haIsStream = is_stream,
 823                         haBufferMode = r_bmode,
 824                         haBuffer = r_buf,
 825                         haBuffers = r_spares,
 826                         haOtherSide = Just write_side
 827                       }
 828   read_side <- newMVar r_handle_
 829
 830   addMVarFinalizer write_side (handleFinalizer write_side)
 831   return (DuplexHandle filepath read_side write_side)
 832
 833
 834 initBufferState ReadHandle = ReadBuffer
 835 initBufferState _          = WriteBuffer
 836
 837 -- ---------------------------------------------------------------------------
 838 -- Closing a handle
 839
 840 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
 841 -- computation finishes, if @hdl@ is writable its buffer is flushed as
 842 -- for 'hFlush'.
 843 -- Performing 'hClose' on a handle that has already been closed has no effect;
 844 -- doing so not an error.  All other operations on a closed handle will fail.
 845 -- If 'hClose' fails for any reason, any further operations (apart from
 846 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
 847 -- closed.
 848
 849 hClose :: Handle -> IO ()
 850 hClose h@(FileHandle _ m)     = hClose' h m
 851 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
 852
 853 hClose' h m = withHandle__' "hClose" h m $ hClose_help
 854
 855 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
 856 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
 857 -- then closed immediately.  We have to be careful with DuplexHandles
 858 -- though: we have to leave the closing to the finalizer in that case,
 859 -- because the write side may still be in use.
 860 hClose_help :: Handle__ -> IO Handle__
 861 hClose_help handle_ =
 862   case haType handle_ of
 863       ClosedHandle -> return handle_
 864       _ -> do flushWriteBufferOnly handle_ -- interruptible
 865               hClose_handle_ handle_
 866
 867 hClose_handle_ handle_ = do
 868     let fd = haFD handle_
 869         c_fd = fromIntegral fd
 870
 871     -- close the file descriptor, but not when this is the read
 872     -- side of a duplex handle, and not when this is one of the
 873     -- std file handles.
 874     case haOtherSide handle_ of
 875       Nothing ->
 876           when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
 877                   throwErrnoIfMinus1Retry_ "hClose"
 878 #ifdef mingw32_TARGET_OS
 879                                 (closeFd (haIsStream handle_) c_fd)
 880 #else
 881                                 (c_close c_fd)
 882 #endif
 883       Just _  -> return ()
 884
 885     -- free the spare buffers
 886     writeIORef (haBuffers handle_) BufferListNil
 887
 888     -- unlock it
 889     unlockFile c_fd
 890
 891     -- we must set the fd to -1, because the finalizer is going
 892     -- to run eventually and try to close/unlock it.
 893     return (handle_{ haFD        = -1,
 894                      haType      = ClosedHandle
 895                    })
 896
 897 -----------------------------------------------------------------------------
 898 -- Detecting the size of a file
 899
 900 -- | For a handle @hdl@ which attached to a physical file,
 901 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
 902
 903 hFileSize :: Handle -> IO Integer
 904 hFileSize handle =
 905     withHandle_ "hFileSize" handle $ \ handle_ -> do
 906     case haType handle_ of
 907       ClosedHandle              -> ioe_closedHandle
 908       SemiClosedHandle          -> ioe_closedHandle
 909       _ -> do flushWriteBufferOnly handle_
 910               r <- fdFileSize (haFD handle_)
 911               if r /= -1
 912                  then return r
 913                  else ioException (IOError Nothing InappropriateType "hFileSize"
 914                                    "not a regular file" Nothing)
 915
 916 -- ---------------------------------------------------------------------------
 917 -- Detecting the End of Input
 918
 919 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
 920 -- 'True' if no further input can be taken from @hdl@ or for a
 921 -- physical file, if the current I\/O position is equal to the length of
 922 -- the file.  Otherwise, it returns 'False'.
 923
 924 hIsEOF :: Handle -> IO Bool
 925 hIsEOF handle =
 926   catch
 927      (do hLookAhead handle; return False)
 928      (\e -> if isEOFError e then return True else ioError e)
 929
 930 -- | The computation 'isEOF' is identical to 'hIsEOF',
 931 -- except that it works only on 'stdin'.
 932
 933 isEOF :: IO Bool
 934 isEOF = hIsEOF stdin
 935
 936 -- ---------------------------------------------------------------------------
 937 -- Looking ahead
 938
 939 -- | Computation 'hLookAhead' returns the next character from the handle
 940 -- without removing it from the input buffer, blocking until a character
 941 -- is available.
 942 --
 943 -- This operation may fail with:
 944 --
 945 --  * 'isEOFError' if the end of file has been reached.
 946
 947 hLookAhead :: Handle -> IO Char
 948 hLookAhead handle = do
 949   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 950   let ref     = haBuffer handle_
 951       fd      = haFD handle_
 952       is_line = haBufferMode handle_ == LineBuffering
 953   buf <- readIORef ref
 954
 955   -- fill up the read buffer if necessary
 956   new_buf <- if bufferEmpty buf
 957                 then fillReadBuffer fd is_line (haIsStream handle_) buf
 958                 else return buf
 959
 960   writeIORef ref new_buf
 961
 962   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 963   return c
 964
 965 -- ---------------------------------------------------------------------------
 966 -- Buffering Operations
 967
 968 -- Three kinds of buffering are supported: line-buffering,
 969 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
 970 -- further explanation of what the type represent.
 971
 972 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
 973 -- handle @hdl@ on subsequent reads and writes.
 974 --
 975 -- If the buffer mode is changed from 'BlockBuffering' or
 976 -- 'LineBuffering' to 'NoBuffering', then
 977 --
 978 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
 979 --
 980 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
 981 --
 982 -- This operation may fail with:
 983 --
 984 --  * 'isPermissionError' if the handle has already been used for reading
 985 --    or writing and the implementation does not allow the buffering mode
 986 --    to be changed.
 987
 988 hSetBuffering :: Handle -> BufferMode -> IO ()
 989 hSetBuffering handle mode =
 990   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 991   case haType handle_ of
 992     ClosedHandle -> ioe_closedHandle
 993     _ -> do
 994          {- Note:
 995             - we flush the old buffer regardless of whether
 996               the new buffer could fit the contents of the old buffer
 997               or not.
 998             - allow a handle's buffering to change even if IO has
 999               occurred (ANSI C spec. does not allow this, nor did
1000               the previous implementation of IO.hSetBuffering).
1001             - a non-standard extension is to allow the buffering
1002               of semi-closed handles to change [sof 6/98]
1003           -}
1004           flushBuffer handle_
1005
1006           let state = initBufferState (haType handle_)
1007           new_buf <-
1008             case mode of
1009                 -- we always have a 1-character read buffer for
1010                 -- unbuffered  handles: it's needed to
1011                 -- support hLookAhead.
1012               NoBuffering            -> allocateBuffer 1 ReadBuffer
1013               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
1014               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1015               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
1016                                       | otherwise -> allocateBuffer n state
1017           writeIORef (haBuffer handle_) new_buf
1018
1019           -- for input terminals we need to put the terminal into
1020           -- cooked or raw mode depending on the type of buffering.
1021           is_tty <- fdIsTTY (haFD handle_)
1022           when (is_tty && isReadableHandleType (haType handle_)) $
1023                 case mode of
1024 #ifndef mingw32_TARGET_OS
1025         -- 'raw' mode under win32 is a bit too specialised (and troublesome
1026         -- for most common uses), so simply disable its use here.
1027                   NoBuffering -> setCooked (haFD handle_) False
1028 #endif
1029                   _           -> setCooked (haFD handle_) True
1030
1031           -- throw away spare buffers, they might be the wrong size
1032           writeIORef (haBuffers handle_) BufferListNil
1033
1034           return (handle_{ haBufferMode = mode })
1035
1036 -- -----------------------------------------------------------------------------
1037 -- hFlush
1038
1039 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1040 -- in handle @hdl@ to be sent immediately to the operating system.
1041 --
1042 -- This operation may fail with:
1043 --
1044 --  * 'isFullError' if the device is full;
1045 --
1046 --  * 'isPermissionError' if a system resource limit would be exceeded.
1047 --    It is unspecified whether the characters in the buffer are discarded
1048 --    or retained under these circumstances.
1049
1050 hFlush :: Handle -> IO ()
1051 hFlush handle =
1052    wantWritableHandle "hFlush" handle $ \ handle_ -> do
1053    buf <- readIORef (haBuffer handle_)
1054    if bufferIsWritable buf && not (bufferEmpty buf)
1055         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1056                 writeIORef (haBuffer handle_) flushed_buf
1057         else return ()
1058
1059
1060 -- -----------------------------------------------------------------------------
1061 -- Repositioning Handles
1062
1063 data HandlePosn = HandlePosn Handle HandlePosition
1064
1065 instance Eq HandlePosn where
1066     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1067
1068 instance Show HandlePosn where
1069    showsPrec p (HandlePosn h pos) =
1070         showsPrec p h . showString " at position " . shows pos
1071
1072   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1073   -- We represent it as an Integer on the Haskell side, but
1074   -- cheat slightly in that hGetPosn calls upon a C helper
1075   -- that reports the position back via (merely) an Int.
1076 type HandlePosition = Integer
1077
1078 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1079 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1080
1081 hGetPosn :: Handle -> IO HandlePosn
1082 hGetPosn handle = do
1083     posn <- hTell handle
1084     return (HandlePosn handle posn)
1085
1086 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1087 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1088 -- to the position it held at the time of the call to 'hGetPosn'.
1089 --
1090 -- This operation may fail with:
1091 --
1092 --  * 'isPermissionError' if a system resource limit would be exceeded.
1093
1094 hSetPosn :: HandlePosn -> IO ()
1095 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1096
1097 -- ---------------------------------------------------------------------------
1098 -- hSeek
1099
1100 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1101 data SeekMode
1102   = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
1103   | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
1104                         -- from the current position.
1105   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
1106                         -- from the end of the file.
1107     deriving (Eq, Ord, Ix, Enum, Read, Show)
1108
1109 {- Note:
1110  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1111    seeking at or past EOF.
1112
1113  - we possibly deviate from the report on the issue of seeking within
1114    the buffer and whether to flush it or not.  The report isn't exactly
1115    clear here.
1116 -}
1117
1118 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1119 -- @hdl@ depending on @mode@.
1120 -- The offset @i@ is given in terms of 8-bit bytes.
1121 --
1122 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1123 -- in the current buffer will first cause any items in the output buffer to be
1124 -- written to the device, and then cause the input buffer to be discarded.
1125 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1126 -- subset of the possible positioning operations (for instance, it may only
1127 -- be possible to seek to the end of a tape, or to a positive offset from
1128 -- the beginning or current position).
1129 -- It is not possible to set a negative I\/O position, or for
1130 -- a physical file, an I\/O position beyond the current end-of-file.
1131 --
1132 -- This operation may fail with:
1133 --
1134 --  * 'isPermissionError' if a system resource limit would be exceeded.
1135
1136 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1137 hSeek handle mode offset =
1138     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1139 #   ifdef DEBUG_DUMP
1140     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1141 #   endif
1142     let ref = haBuffer handle_
1143     buf <- readIORef ref
1144     let r = bufRPtr buf
1145         w = bufWPtr buf
1146         fd = haFD handle_
1147
1148     let do_seek =
1149           throwErrnoIfMinus1Retry_ "hSeek"
1150             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1151
1152         whence :: CInt
1153         whence = case mode of
1154                    AbsoluteSeek -> sEEK_SET
1155                    RelativeSeek -> sEEK_CUR
1156                    SeekFromEnd  -> sEEK_END
1157
1158     if bufferIsWritable buf
1159         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1160                 writeIORef ref new_buf
1161                 do_seek
1162         else do
1163
1164     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1165         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1166         else do
1167
1168     new_buf <- flushReadBuffer (haFD handle_) buf
1169     writeIORef ref new_buf
1170     do_seek
1171
1172
1173 hTell :: Handle -> IO Integer
1174 hTell handle =
1175     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1176
1177 #if defined(mingw32_TARGET_OS)
1178         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1179         -- so we can't easily calculate the file position using the
1180         -- current buffer size.  Just flush instead.
1181       flushBuffer handle_
1182 #endif
1183       let fd = fromIntegral (haFD handle_)
1184       posn <- fromIntegral `liftM`
1185                 throwErrnoIfMinus1Retry "hGetPosn"
1186                    (c_lseek fd 0 sEEK_CUR)
1187
1188       let ref = haBuffer handle_
1189       buf <- readIORef ref
1190
1191       let real_posn
1192            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1193            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1194 #     ifdef DEBUG_DUMP
1195       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1196       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1197 #     endif
1198       return real_posn
1199
1200 -- -----------------------------------------------------------------------------
1201 -- Handle Properties
1202
1203 -- A number of operations return information about the properties of a
1204 -- handle.  Each of these operations returns `True' if the handle has
1205 -- the specified property, and `False' otherwise.
1206
1207 hIsOpen :: Handle -> IO Bool
1208 hIsOpen handle =
1209     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1210     case haType handle_ of
1211       ClosedHandle         -> return False
1212       SemiClosedHandle     -> return False
1213       _                    -> return True
1214
1215 hIsClosed :: Handle -> IO Bool
1216 hIsClosed handle =
1217     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1218     case haType handle_ of
1219       ClosedHandle         -> return True
1220       _                    -> return False
1221
1222 {- not defined, nor exported, but mentioned
1223    here for documentation purposes:
1224
1225     hSemiClosed :: Handle -> IO Bool
1226     hSemiClosed h = do
1227        ho <- hIsOpen h
1228        hc <- hIsClosed h
1229        return (not (ho || hc))
1230 -}
1231
1232 hIsReadable :: Handle -> IO Bool
1233 hIsReadable (DuplexHandle _ _ _) = return True
1234 hIsReadable handle =
1235     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1236     case haType handle_ of
1237       ClosedHandle         -> ioe_closedHandle
1238       SemiClosedHandle     -> ioe_closedHandle
1239       htype                -> return (isReadableHandleType htype)
1240
1241 hIsWritable :: Handle -> IO Bool
1242 hIsWritable (DuplexHandle _ _ _) = return True
1243 hIsWritable handle =
1244     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1245     case haType handle_ of
1246       ClosedHandle         -> ioe_closedHandle
1247       SemiClosedHandle     -> ioe_closedHandle
1248       htype                -> return (isWritableHandleType htype)
1249
1250 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1251 -- for @hdl@.
1252
1253 hGetBuffering :: Handle -> IO BufferMode
1254 hGetBuffering handle =
1255     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1256     case haType handle_ of
1257       ClosedHandle         -> ioe_closedHandle
1258       _ ->
1259            -- We're being non-standard here, and allow the buffering
1260            -- of a semi-closed handle to be queried.   -- sof 6/98
1261           return (haBufferMode handle_)  -- could be stricter..
1262
1263 hIsSeekable :: Handle -> IO Bool
1264 hIsSeekable handle =
1265     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1266     case haType handle_ of
1267       ClosedHandle         -> ioe_closedHandle
1268       SemiClosedHandle     -> ioe_closedHandle
1269       AppendHandle         -> return False
1270       _                    -> do t <- fdType (haFD handle_)
1271                                  return (t == RegularFile
1272                                          && (haIsBin handle_
1273                                                 || tEXT_MODE_SEEK_ALLOWED))
1274
1275 -- -----------------------------------------------------------------------------
1276 -- Changing echo status (Non-standard GHC extensions)
1277
1278 -- | Set the echoing status of a handle connected to a terminal (GHC only).
1279
1280 hSetEcho :: Handle -> Bool -> IO ()
1281 hSetEcho handle on = do
1282     isT   <- hIsTerminalDevice handle
1283     if not isT
1284      then return ()
1285      else
1286       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1287       case haType handle_ of
1288          ClosedHandle -> ioe_closedHandle
1289          _            -> setEcho (haFD handle_) on
1290
1291 -- | Get the echoing status of a handle connected to a terminal (GHC only).
1292
1293 hGetEcho :: Handle -> IO Bool
1294 hGetEcho handle = do
1295     isT   <- hIsTerminalDevice handle
1296     if not isT
1297      then return False
1298      else
1299        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1300        case haType handle_ of
1301          ClosedHandle -> ioe_closedHandle
1302          _            -> getEcho (haFD handle_)
1303
1304 -- | Is the handle connected to a terminal? (GHC only)
1305
1306 hIsTerminalDevice :: Handle -> IO Bool
1307 hIsTerminalDevice handle = do
1308     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1309      case haType handle_ of
1310        ClosedHandle -> ioe_closedHandle
1311        _            -> fdIsTTY (haFD handle_)
1312
1313 -- -----------------------------------------------------------------------------
1314 -- hSetBinaryMode
1315
1316 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1317 -- (GHC only; see also 'openBinaryFile'.)
1318
1319 hSetBinaryMode :: Handle -> Bool -> IO ()
1320 hSetBinaryMode handle bin =
1321   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1322     do throwErrnoIfMinus1_ "hSetBinaryMode"
1323           (setmode (fromIntegral (haFD handle_)) bin)
1324        return handle_{haIsBin=bin}
1325
1326 foreign import ccall unsafe "__hscore_setmode"
1327   setmode :: CInt -> Bool -> IO CInt
1328
1329 -- -----------------------------------------------------------------------------
1330 -- Duplicating a Handle
1331
1332 -- |Returns a duplicate of the original handle, with its own buffer
1333 -- and file pointer.  The original handle's buffer is flushed, including
1334 -- discarding any input data, before the handle is duplicated.
1335
1336 hDuplicate :: Handle -> IO Handle
1337 hDuplicate h@(FileHandle path m) = do
1338   new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1339   new_m <- newMVar new_h_
1340   return (FileHandle path new_m)
1341 hDuplicate h@(DuplexHandle path r w) = do
1342   new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1343   new_w <- newMVar new_w_
1344   new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1345   new_r <- newMVar new_r_
1346   return (DuplexHandle path new_r new_w)
1347
1348 dupHandle_ other_side h_ = do
1349   -- flush the buffer first, so we don't have to copy its contents
1350   flushBuffer h_
1351   new_fd <- c_dup (fromIntegral (haFD h_))
1352   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1353   ioref <- newIORef buffer
1354   ioref_buffers <- newIORef BufferListNil
1355
1356   let new_handle_ = h_{ haFD = fromIntegral new_fd,
1357                         haBuffer = ioref,
1358                         haBuffers = ioref_buffers,
1359                         haOtherSide = other_side }
1360   return (h_, new_handle_)
1361
1362 -- -----------------------------------------------------------------------------
1363 -- Replacing a Handle
1364
1365 {- |
1366 Makes the second handle a duplicate of the first handle.  The second
1367 handle will be closed first, if it is not already.
1368
1369 This can be used to retarget the standard Handles, for example:
1370
1371 > do h <- openFile "mystdout" WriteMode
1372 >    hDuplicateTo h stdout
1373 -}
1374
1375 hDuplicateTo :: Handle -> Handle -> IO ()
1376 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
1377  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1378    _ <- hClose_help h2_
1379    withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1380 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
1381  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
1382    _ <- hClose_help w2_
1383    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1384  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
1385    _ <- hClose_help r2_
1386    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1387 hDuplicateTo h1 _ =
1388    ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1389                 "handles are incompatible" Nothing)
1390
1391 -- ---------------------------------------------------------------------------
1392 -- showing Handles.
1393 --
1394 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1395 -- than the (pure) instance of 'Show' for 'Handle'.
1396
1397 hShow :: Handle -> IO String
1398 hShow h@(FileHandle path _) = showHandle' path False h
1399 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1400
1401 showHandle' filepath is_duplex h =
1402   withHandle_ "showHandle" h $ \hdl_ ->
1403     let
1404      showType | is_duplex = showString "duplex (read-write)"
1405               | otherwise = shows (haType hdl_)
1406     in
1407     return
1408       (( showChar '{' .
1409         showHdl (haType hdl_)
1410             (showString "loc=" . showString filepath . showChar ',' .
1411              showString "type=" . showType . showChar ',' .
1412              showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1413              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1414       ) "")
1415    where
1416
1417     showHdl :: HandleType -> ShowS -> ShowS
1418     showHdl ht cont =
1419        case ht of
1420         ClosedHandle  -> shows ht . showString "}"
1421         _ -> cont
1422
1423     showBufMode :: Buffer -> BufferMode -> ShowS
1424     showBufMode buf bmo =
1425       case bmo of
1426         NoBuffering   -> showString "none"
1427         LineBuffering -> showString "line"
1428         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1429         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
1430       where
1431        def :: Int
1432        def = bufSize buf
1433
1434 -- ---------------------------------------------------------------------------
1435 -- debugging
1436
1437 #ifdef DEBUG_DUMP
1438 puts :: String -> IO ()
1439 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1440                                      return ()
1441 #endif
1442
1443 -- -----------------------------------------------------------------------------
1444 -- wrappers to platform-specific constants:
1445
1446 foreign import ccall unsafe "__hscore_supportsTextMode"
1447   tEXT_MODE_SEEK_ALLOWED :: Bool
1448
1449 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1450 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1451 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1452 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt