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