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