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