GHC/Handle.hs

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