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, fdToHandle,
  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 IOModeEx
 559  = BinaryMode IOMode
 560  | TextMode   IOMode
 561    deriving (Eq, Read, Show)
 562
 563 addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
 564   = IOException (IOError h iot fun str (Just fp))
 565 addFilePathToIOError _   _  other_exception
 566   = other_exception
 567
 568 openFile :: FilePath -> IOMode -> IO Handle
 569 openFile fp im =
 570   catch
 571     (openFile' fp (if   dEFAULT_OPEN_IN_BINARY_MODE
 572                    then BinaryMode im
 573                    else TextMode im))
 574     (\e -> throw (addFilePathToIOError "openFile" fp e))
 575
 576 openFileEx :: FilePath -> IOModeEx -> IO Handle
 577 openFileEx fp m =
 578   catch
 579     (openFile' fp m)
 580     (\e -> throw (addFilePathToIOError "openFileEx" fp e))
 581
 582
 583 openFile' filepath ex_mode =
 584   withCString filepath $ \ f ->
 585
 586     let
 587       (mode, binary) =
 588         case ex_mode of
 589            BinaryMode bmo -> (bmo, True)
 590            TextMode   tmo -> (tmo, False)
 591
 592       oflags1 = case mode of
 593                   ReadMode      -> read_flags
 594                   WriteMode     -> write_flags
 595                   ReadWriteMode -> rw_flags
 596                   AppendMode    -> append_flags
 597
 598       truncate | WriteMode <- mode = True
 599                | otherwise         = False
 600
 601       binary_flags
 602           | binary    = o_BINARY
 603           | otherwise = 0
 604
 605       oflags = oflags1 .|. binary_flags
 606     in do
 607
 608     -- the old implementation had a complicated series of three opens,
 609     -- which is perhaps because we have to be careful not to open
 610     -- directories.  However, the man pages I've read say that open()
 611     -- always returns EISDIR if the file is a directory and was opened
 612     -- for writing, so I think we're ok with a single open() here...
 613     fd <- fromIntegral `liftM`
 614               throwErrnoIfMinus1Retry "openFile"
 615                 (c_open f (fromIntegral oflags) 0o666)
 616
 617     openFd fd Nothing filepath mode binary truncate
 618         -- ASSERT: if we just created the file, then openFd won't fail
 619         -- (so we don't need to worry about removing the newly created file
 620         --  in the event of an error).
 621
 622
 623 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 624 output_flags = std_flags    .|. o_CREAT
 625 read_flags   = std_flags    .|. o_RDONLY
 626 write_flags  = output_flags .|. o_WRONLY
 627 rw_flags     = output_flags .|. o_RDWR
 628 append_flags = write_flags  .|. o_APPEND
 629
 630 -- ---------------------------------------------------------------------------
 631 -- openFd
 632
 633 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
 634 openFd fd mb_fd_type filepath mode binary truncate = do
 635     -- turn on non-blocking mode
 636     setNonBlockingFD fd
 637
 638     let (ha_type, write) =
 639           case mode of
 640             ReadMode      -> ( ReadHandle,      False )
 641             WriteMode     -> ( WriteHandle,     True )
 642             ReadWriteMode -> ( ReadWriteHandle, True )
 643             AppendMode    -> ( AppendHandle,    True )
 644
 645     -- open() won't tell us if it was a directory if we only opened for
 646     -- reading, so check again.
 647     fd_type <-
 648       case mb_fd_type of
 649         Just x  -> return x
 650         Nothing -> fdType fd
 651     let is_stream = fd_type == Stream
 652     case fd_type of
 653         Directory ->
 654            ioException (IOError Nothing InappropriateType "openFile"
 655                            "is a directory" Nothing)
 656
 657         Stream
 658            | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
 659            | otherwise                  -> mkFileHandle fd is_stream filepath ha_type binary
 660
 661         -- regular files need to be locked
 662         RegularFile -> do
 663            r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 664            when (r == -1)  $
 665                 ioException (IOError Nothing ResourceBusy "openFile"
 666                                    "file is locked" Nothing)
 667
 668            -- truncate the file if necessary
 669            when truncate (fileTruncate filepath)
 670
 671            mkFileHandle fd is_stream filepath ha_type binary
 672
 673
 674 fdToHandle :: FD -> IO Handle
 675 fdToHandle fd = do
 676    mode <- fdGetMode fd
 677    let fd_str = "<file descriptor: " ++ show fd ++ ">"
 678    openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
 679
 680 foreign import ccall unsafe "lockFile"
 681   lockFile :: CInt -> CInt -> CInt -> IO CInt
 682
 683 foreign import ccall unsafe "unlockFile"
 684   unlockFile :: CInt -> IO CInt
 685
 686 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
 687         -> IO Handle
 688 mkStdHandle fd filepath ha_type buf bmode = do
 689    spares <- newIORef BufferListNil
 690    newFileHandle stdHandleFinalizer
 691             (Handle__ { haFD = fd,
 692                         haType = ha_type,
 693                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
 694                         haIsStream = False,
 695                         haBufferMode = bmode,
 696                         haFilePath = filepath,
 697                         haBuffer = buf,
 698                         haBuffers = spares,
 699                         haOtherSide = Nothing
 700                       })
 701
 702 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 703 mkFileHandle fd is_stream filepath ha_type binary = do
 704   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 705   spares <- newIORef BufferListNil
 706   newFileHandle handleFinalizer
 707             (Handle__ { haFD = fd,
 708                         haType = ha_type,
 709                         haIsBin = binary,
 710                         haIsStream = is_stream,
 711                         haBufferMode = bmode,
 712                         haFilePath = filepath,
 713                         haBuffer = buf,
 714                         haBuffers = spares,
 715                         haOtherSide = Nothing
 716                       })
 717
 718 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
 719 mkDuplexHandle fd is_stream filepath binary = do
 720   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 721   w_spares <- newIORef BufferListNil
 722   let w_handle_ =
 723              Handle__ { haFD = fd,
 724                         haType = WriteHandle,
 725                         haIsBin = binary,
 726                         haIsStream = is_stream,
 727                         haBufferMode = w_bmode,
 728                         haFilePath = filepath,
 729                         haBuffer = w_buf,
 730                         haBuffers = w_spares,
 731                         haOtherSide = Nothing
 732                       }
 733   write_side <- newMVar w_handle_
 734
 735   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 736   r_spares <- newIORef BufferListNil
 737   let r_handle_ =
 738              Handle__ { haFD = fd,
 739                         haType = ReadHandle,
 740                         haIsBin = binary,
 741                         haIsStream = is_stream,
 742                         haBufferMode = r_bmode,
 743                         haFilePath = filepath,
 744                         haBuffer = r_buf,
 745                         haBuffers = r_spares,
 746                         haOtherSide = Just write_side
 747                       }
 748   read_side <- newMVar r_handle_
 749
 750   addMVarFinalizer read_side (handleFinalizer read_side)
 751   return (DuplexHandle read_side write_side)
 752
 753
 754 initBufferState ReadHandle = ReadBuffer
 755 initBufferState _          = WriteBuffer
 756
 757 -- ---------------------------------------------------------------------------
 758 -- Closing a handle
 759
 760 -- Computation `hClose hdl' makes handle `hdl' closed.  Before the
 761 -- computation finishes, any items buffered for output and not already
 762 -- sent to the operating system are flushed as for `hFlush'.
 763
 764 -- For a duplex handle, we close&flush the write side, and just close
 765 -- the read side.
 766
 767 hClose :: Handle -> IO ()
 768 hClose h@(FileHandle m)     = hClose' h m
 769 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
 770
 771 hClose' h m = withHandle__' "hClose" h m $ hClose_help
 772
 773 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
 774 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
 775 -- then closed immediately.  We have to be careful with DuplexHandles
 776 -- though: we have to leave the closing to the finalizer in that case,
 777 -- because the write side may still be in use.
 778 hClose_help :: Handle__ -> IO Handle__
 779 hClose_help handle_ =
 780   case haType handle_ of
 781       ClosedHandle -> return handle_
 782       _ -> do
 783           let fd = haFD handle_
 784               c_fd = fromIntegral fd
 785
 786           flushWriteBufferOnly handle_
 787
 788           -- close the file descriptor, but not when this is the read
 789           -- side of a duplex handle, and not when this is one of the
 790           -- std file handles.
 791           case haOtherSide handle_ of
 792             Nothing ->
 793                 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
 794                         throwErrnoIfMinus1Retry_ "hClose"
 795 #ifdef mingw32_TARGET_OS
 796                                 (closeFd (haIsStream handle_) c_fd)
 797 #else
 798                                 (c_close c_fd)
 799 #endif
 800             Just _  -> return ()
 801
 802           -- free the spare buffers
 803           writeIORef (haBuffers handle_) BufferListNil
 804
 805           -- unlock it
 806           unlockFile c_fd
 807
 808           -- we must set the fd to -1, because the finalizer is going
 809           -- to run eventually and try to close/unlock it.
 810           return (handle_{ haFD        = -1,
 811                            haType      = ClosedHandle
 812                          })
 813
 814 -----------------------------------------------------------------------------
 815 -- Detecting the size of a file
 816
 817 -- For a handle `hdl' which attached to a physical file, `hFileSize
 818 -- hdl' returns the size of `hdl' in terms of the number of items
 819 -- which can be read from `hdl'.
 820
 821 hFileSize :: Handle -> IO Integer
 822 hFileSize handle =
 823     withHandle_ "hFileSize" handle $ \ handle_ -> do
 824     case haType handle_ of
 825       ClosedHandle              -> ioe_closedHandle
 826       SemiClosedHandle          -> ioe_closedHandle
 827       _ -> do flushWriteBufferOnly handle_
 828               r <- fdFileSize (haFD handle_)
 829               if r /= -1
 830                  then return r
 831                  else ioException (IOError Nothing InappropriateType "hFileSize"
 832                                    "not a regular file" Nothing)
 833
 834 -- ---------------------------------------------------------------------------
 835 -- Detecting the End of Input
 836
 837 -- For a readable handle `hdl', `hIsEOF hdl' returns
 838 -- `True' if no further input can be taken from `hdl' or for a
 839 -- physical file, if the current I/O position is equal to the length of
 840 -- the file.  Otherwise, it returns `False'.
 841
 842 hIsEOF :: Handle -> IO Bool
 843 hIsEOF handle =
 844   catch
 845      (do hLookAhead handle; return False)
 846      (\e -> if isEOFError e then return True else throw e)
 847
 848 isEOF :: IO Bool
 849 isEOF = hIsEOF stdin
 850
 851 -- ---------------------------------------------------------------------------
 852 -- Looking ahead
 853
 854 -- hLookahead returns the next character from the handle without
 855 -- removing it from the input buffer, blocking until a character is
 856 -- available.
 857
 858 hLookAhead :: Handle -> IO Char
 859 hLookAhead handle = do
 860   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 861   let ref     = haBuffer handle_
 862       fd      = haFD handle_
 863       is_line = haBufferMode handle_ == LineBuffering
 864   buf <- readIORef ref
 865
 866   -- fill up the read buffer if necessary
 867   new_buf <- if bufferEmpty buf
 868                 then fillReadBuffer fd is_line (haIsStream handle_) buf
 869                 else return buf
 870
 871   writeIORef ref new_buf
 872
 873   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 874   return c
 875
 876 -- ---------------------------------------------------------------------------
 877 -- Buffering Operations
 878
 879 -- Three kinds of buffering are supported: line-buffering,
 880 -- block-buffering or no-buffering.  See GHC.IOBase for definition and
 881 -- further explanation of what the type represent.
 882
 883 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 884 -- handle hdl on subsequent reads and writes.
 885 --
 886 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 887 --
 888 --   * If mode is `BlockBuffering size', then block-buffering
 889 --     should be enabled if possible.  The size of the buffer is n items
 890 --     if size is `Just n' and is otherwise implementation-dependent.
 891 --
 892 --   * If mode is NoBuffering, then buffering is disabled if possible.
 893
 894 -- If the buffer mode is changed from BlockBuffering or
 895 -- LineBuffering to NoBuffering, then any items in the output
 896 -- buffer are written to the device, and any items in the input buffer
 897 -- are discarded.  The default buffering mode when a handle is opened
 898 -- is implementation-dependent and may depend on the object which is
 899 -- attached to that handle.
 900
 901 hSetBuffering :: Handle -> BufferMode -> IO ()
 902 hSetBuffering handle mode =
 903   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 904   case haType handle_ of
 905     ClosedHandle -> ioe_closedHandle
 906     _ -> do
 907          {- Note:
 908             - we flush the old buffer regardless of whether
 909               the new buffer could fit the contents of the old buffer
 910               or not.
 911             - allow a handle's buffering to change even if IO has
 912               occurred (ANSI C spec. does not allow this, nor did
 913               the previous implementation of IO.hSetBuffering).
 914             - a non-standard extension is to allow the buffering
 915               of semi-closed handles to change [sof 6/98]
 916           -}
 917           flushBuffer handle_
 918
 919           let state = initBufferState (haType handle_)
 920           new_buf <-
 921             case mode of
 922                 -- we always have a 1-character read buffer for
 923                 -- unbuffered  handles: it's needed to
 924                 -- support hLookAhead.
 925               NoBuffering            -> allocateBuffer 1 ReadBuffer
 926               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 927               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 928               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 929                                       | otherwise -> allocateBuffer n state
 930           writeIORef (haBuffer handle_) new_buf
 931
 932           -- for input terminals we need to put the terminal into
 933           -- cooked or raw mode depending on the type of buffering.
 934           is_tty <- fdIsTTY (haFD handle_)
 935           when (is_tty && isReadableHandleType (haType handle_)) $
 936                 case mode of
 937                   NoBuffering -> setCooked (haFD handle_) False
 938                   _           -> setCooked (haFD handle_) True
 939
 940           -- throw away spare buffers, they might be the wrong size
 941           writeIORef (haBuffers handle_) BufferListNil
 942
 943           return (handle_{ haBufferMode = mode })
 944
 945 -- -----------------------------------------------------------------------------
 946 -- hFlush
 947
 948 -- The action `hFlush hdl' causes any items buffered for output
 949 -- in handle `hdl' to be sent immediately to the operating
 950 -- system.
 951
 952 hFlush :: Handle -> IO ()
 953 hFlush handle =
 954    wantWritableHandle "hFlush" handle $ \ handle_ -> do
 955    buf <- readIORef (haBuffer handle_)
 956    if bufferIsWritable buf && not (bufferEmpty buf)
 957         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
 958                 writeIORef (haBuffer handle_) flushed_buf
 959         else return ()
 960
 961
 962 -- -----------------------------------------------------------------------------
 963 -- Repositioning Handles
 964
 965 data HandlePosn = HandlePosn Handle HandlePosition
 966
 967 instance Eq HandlePosn where
 968     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 969
 970 instance Show HandlePosn where
 971    showsPrec p (HandlePosn h pos) =
 972         showsPrec p h . showString " at position " . shows pos
 973
 974   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 975   -- We represent it as an Integer on the Haskell side, but
 976   -- cheat slightly in that hGetPosn calls upon a C helper
 977   -- that reports the position back via (merely) an Int.
 978 type HandlePosition = Integer
 979
 980 -- Computation `hGetPosn hdl' returns the current I/O position of
 981 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
 982 -- position of `hdl' to a previously obtained position `p'.
 983
 984 hGetPosn :: Handle -> IO HandlePosn
 985 hGetPosn handle = do
 986     posn <- hTell handle
 987     return (HandlePosn handle posn)
 988
 989 hSetPosn :: HandlePosn -> IO ()
 990 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 991
 992 -- ---------------------------------------------------------------------------
 993 -- hSeek
 994
 995 {-
 996 The action `hSeek hdl mode i' sets the position of handle
 997 `hdl' depending on `mode'.  If `mode' is
 998
 999  * AbsoluteSeek - The position of `hdl' is set to `i'.
1000  * RelativeSeek - The position of `hdl' is set to offset `i' from
1001                   the current position.
1002  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
1003                   the end of the file.
1004
1005 Some handles may not be seekable (see `hIsSeekable'), or only
1006 support a subset of the possible positioning operations (e.g. it may
1007 only be possible to seek to the end of a tape, or to a positive
1008 offset from the beginning or current position).
1009
1010 It is not possible to set a negative I/O position, or for a physical
1011 file, an I/O position beyond the current end-of-file.
1012
1013 Note:
1014  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1015    seeking at or past EOF.
1016
1017  - we possibly deviate from the report on the issue of seeking within
1018    the buffer and whether to flush it or not.  The report isn't exactly
1019    clear here.
1020 -}
1021
1022 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
1023                     deriving (Eq, Ord, Ix, Enum, Read, Show)
1024
1025 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1026 hSeek handle mode offset =
1027     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1028 #   ifdef DEBUG_DUMP
1029     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1030 #   endif
1031     let ref = haBuffer handle_
1032     buf <- readIORef ref
1033     let r = bufRPtr buf
1034         w = bufWPtr buf
1035         fd = haFD handle_
1036
1037     let do_seek =
1038           throwErrnoIfMinus1Retry_ "hSeek"
1039             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1040
1041         whence :: CInt
1042         whence = case mode of
1043                    AbsoluteSeek -> sEEK_SET
1044                    RelativeSeek -> sEEK_CUR
1045                    SeekFromEnd  -> sEEK_END
1046
1047     if bufferIsWritable buf
1048         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1049                 writeIORef ref new_buf
1050                 do_seek
1051         else do
1052
1053     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1054         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1055         else do
1056
1057     new_buf <- flushReadBuffer (haFD handle_) buf
1058     writeIORef ref new_buf
1059     do_seek
1060
1061
1062 hTell :: Handle -> IO Integer
1063 hTell handle =
1064     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1065
1066 #if defined(mingw32_TARGET_OS)
1067         -- urgh, on Windows we have to worry about \n -> \r\n translation,
1068         -- so we can't easily calculate the file position using the
1069         -- current buffer size.  Just flush instead.
1070       flushBuffer handle_
1071 #endif
1072       let fd = fromIntegral (haFD handle_)
1073       posn <- fromIntegral `liftM`
1074                 throwErrnoIfMinus1Retry "hGetPosn"
1075                    (c_lseek fd 0 sEEK_CUR)
1076
1077       let ref = haBuffer handle_
1078       buf <- readIORef ref
1079
1080       let real_posn
1081            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1082            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1083 #     ifdef DEBUG_DUMP
1084       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1085       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1086 #     endif
1087       return real_posn
1088
1089 -- -----------------------------------------------------------------------------
1090 -- Handle Properties
1091
1092 -- A number of operations return information about the properties of a
1093 -- handle.  Each of these operations returns `True' if the handle has
1094 -- the specified property, and `False' otherwise.
1095
1096 hIsOpen :: Handle -> IO Bool
1097 hIsOpen handle =
1098     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1099     case haType handle_ of
1100       ClosedHandle         -> return False
1101       SemiClosedHandle     -> return False
1102       _                    -> return True
1103
1104 hIsClosed :: Handle -> IO Bool
1105 hIsClosed handle =
1106     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1107     case haType handle_ of
1108       ClosedHandle         -> return True
1109       _                    -> return False
1110
1111 {- not defined, nor exported, but mentioned
1112    here for documentation purposes:
1113
1114     hSemiClosed :: Handle -> IO Bool
1115     hSemiClosed h = do
1116        ho <- hIsOpen h
1117        hc <- hIsClosed h
1118        return (not (ho || hc))
1119 -}
1120
1121 hIsReadable :: Handle -> IO Bool
1122 hIsReadable (DuplexHandle _ _) = return True
1123 hIsReadable handle =
1124     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1125     case haType handle_ of
1126       ClosedHandle         -> ioe_closedHandle
1127       SemiClosedHandle     -> ioe_closedHandle
1128       htype                -> return (isReadableHandleType htype)
1129
1130 hIsWritable :: Handle -> IO Bool
1131 hIsWritable (DuplexHandle _ _) = return False
1132 hIsWritable handle =
1133     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1134     case haType handle_ of
1135       ClosedHandle         -> ioe_closedHandle
1136       SemiClosedHandle     -> ioe_closedHandle
1137       htype                -> return (isWritableHandleType htype)
1138
1139 -- Querying how a handle buffers its data:
1140
1141 hGetBuffering :: Handle -> IO BufferMode
1142 hGetBuffering handle =
1143     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1144     case haType handle_ of
1145       ClosedHandle         -> ioe_closedHandle
1146       _ ->
1147            -- We're being non-standard here, and allow the buffering
1148            -- of a semi-closed handle to be queried.   -- sof 6/98
1149           return (haBufferMode handle_)  -- could be stricter..
1150
1151 hIsSeekable :: Handle -> IO Bool
1152 hIsSeekable handle =
1153     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1154     case haType handle_ of
1155       ClosedHandle         -> ioe_closedHandle
1156       SemiClosedHandle     -> ioe_closedHandle
1157       AppendHandle         -> return False
1158       _                    -> do t <- fdType (haFD handle_)
1159                                  return (t == RegularFile
1160                                          && (haIsBin handle_
1161                                                 || tEXT_MODE_SEEK_ALLOWED))
1162
1163 -- -----------------------------------------------------------------------------
1164 -- Changing echo status
1165
1166 -- Non-standard GHC extension is to allow the echoing status
1167 -- of a handles connected to terminals to be reconfigured:
1168
1169 hSetEcho :: Handle -> Bool -> IO ()
1170 hSetEcho handle on = do
1171     isT   <- hIsTerminalDevice handle
1172     if not isT
1173      then return ()
1174      else
1175       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1176       case haType handle_ of
1177          ClosedHandle -> ioe_closedHandle
1178          _            -> setEcho (haFD handle_) on
1179
1180 hGetEcho :: Handle -> IO Bool
1181 hGetEcho handle = do
1182     isT   <- hIsTerminalDevice handle
1183     if not isT
1184      then return False
1185      else
1186        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1187        case haType handle_ of
1188          ClosedHandle -> ioe_closedHandle
1189          _            -> getEcho (haFD handle_)
1190
1191 hIsTerminalDevice :: Handle -> IO Bool
1192 hIsTerminalDevice handle = do
1193     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1194      case haType handle_ of
1195        ClosedHandle -> ioe_closedHandle
1196        _            -> fdIsTTY (haFD handle_)
1197
1198 -- -----------------------------------------------------------------------------
1199 -- hSetBinaryMode
1200
1201 -- | On Windows, reading a file in text mode (which is the default) will
1202 -- translate CRLF to LF, and writing will translate LF to CRLF. This
1203 -- is usually what you want with text files. With binary files this is
1204 -- undesirable; also, as usual under Microsoft operating systems, text
1205 -- mode treats control-Z as EOF.  Setting binary mode using
1206 -- 'hSetBinaryMode' turns off all special treatment of end-of-line and
1207 -- end-of-file characters.
1208 --
1209 hSetBinaryMode :: Handle -> Bool -> IO ()
1210 hSetBinaryMode handle bin =
1211   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1212     do throwErrnoIfMinus1_ "hSetBinaryMode"
1213           (setmode (fromIntegral (haFD handle_)) bin)
1214        return handle_{haIsBin=bin}
1215
1216 foreign import ccall unsafe "__hscore_setmode"
1217   setmode :: CInt -> Bool -> IO CInt
1218
1219 -- ---------------------------------------------------------------------------
1220 -- debugging
1221
1222 #ifdef DEBUG_DUMP
1223 puts :: String -> IO ()
1224 puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
1225                                      return ()
1226 #endif
1227
1228 -- -----------------------------------------------------------------------------
1229 -- wrappers to platform-specific constants:
1230
1231 foreign import ccall unsafe "__hscore_supportsTextMode"
1232   tEXT_MODE_SEEK_ALLOWED :: Bool
1233
1234 foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
1235 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1236 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1237 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt