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