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