ghc/lib/std/PrelHandle.hs

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