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