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