GHC/Handle.hs

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