GHC/Handle.hs

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