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.7 2001/12/27 09:28:10 sof 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    = PrelHandle.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 = fromIntegral (haFD handle_)
 772           flushWriteBufferOnly handle_
 773
 774           -- close the file descriptor, but not when this is the read side
 775           -- of a duplex handle.
 776           case haOtherSide handle_ of
 777             Nothing -> throwErrnoIfMinus1Retry_ "hClose"
 778 #ifdef mingw32_TARGET_OS
 779                                                 (closeFd (haIsStream handle_) fd)
 780 #else
 781                                                 (c_close fd)
 782 #endif
 783             Just _  -> return ()
 784
 785           -- free the spare buffers
 786           writeIORef (haBuffers handle_) BufferListNil
 787
 788           -- unlock it
 789           unlockFile fd
 790
 791           -- we must set the fd to -1, because the finalizer is going
 792           -- to run eventually and try to close/unlock it.
 793           return (handle_{ haFD        = -1,
 794                            haType      = ClosedHandle
 795                          })
 796
 797 -----------------------------------------------------------------------------
 798 -- Detecting the size of a file
 799
 800 -- For a handle `hdl' which attached to a physical file, `hFileSize
 801 -- hdl' returns the size of `hdl' in terms of the number of items
 802 -- which can be read from `hdl'.
 803
 804 hFileSize :: Handle -> IO Integer
 805 hFileSize handle =
 806     withHandle_ "hFileSize" handle $ \ handle_ -> do
 807     case haType handle_ of
 808       ClosedHandle              -> ioe_closedHandle
 809       SemiClosedHandle          -> ioe_closedHandle
 810       _ -> do flushWriteBufferOnly handle_
 811               r <- fdFileSize (haFD handle_)
 812               if r /= -1
 813                  then return r
 814                  else ioException (IOError Nothing InappropriateType "hFileSize"
 815                                    "not a regular file" Nothing)
 816
 817 -- ---------------------------------------------------------------------------
 818 -- Detecting the End of Input
 819
 820 -- For a readable handle `hdl', `hIsEOF hdl' returns
 821 -- `True' if no further input can be taken from `hdl' or for a
 822 -- physical file, if the current I/O position is equal to the length of
 823 -- the file.  Otherwise, it returns `False'.
 824
 825 hIsEOF :: Handle -> IO Bool
 826 hIsEOF handle =
 827   catch
 828      (do hLookAhead handle; return False)
 829      (\e -> if isEOFError e then return True else throw e)
 830
 831 isEOF :: IO Bool
 832 isEOF = hIsEOF stdin
 833
 834 -- ---------------------------------------------------------------------------
 835 -- Looking ahead
 836
 837 -- hLookahead returns the next character from the handle without
 838 -- removing it from the input buffer, blocking until a character is
 839 -- available.
 840
 841 hLookAhead :: Handle -> IO Char
 842 hLookAhead handle = do
 843   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 844   let ref     = haBuffer handle_
 845       fd      = haFD handle_
 846       is_line = haBufferMode handle_ == LineBuffering
 847   buf <- readIORef ref
 848
 849   -- fill up the read buffer if necessary
 850   new_buf <- if bufferEmpty buf
 851                 then fillReadBuffer fd is_line (haIsStream handle_) buf
 852                 else return buf
 853
 854   writeIORef ref new_buf
 855
 856   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 857   return c
 858
 859 -- ---------------------------------------------------------------------------
 860 -- Buffering Operations
 861
 862 -- Three kinds of buffering are supported: line-buffering,
 863 -- block-buffering or no-buffering.  See PrelIOBase for definition and
 864 -- further explanation of what the type represent.
 865
 866 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 867 -- handle hdl on subsequent reads and writes.
 868 --
 869 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 870 --
 871 --   * If mode is `BlockBuffering size', then block-buffering
 872 --     should be enabled if possible.  The size of the buffer is n items
 873 --     if size is `Just n' and is otherwise implementation-dependent.
 874 --
 875 --   * If mode is NoBuffering, then buffering is disabled if possible.
 876
 877 -- If the buffer mode is changed from BlockBuffering or
 878 -- LineBuffering to NoBuffering, then any items in the output
 879 -- buffer are written to the device, and any items in the input buffer
 880 -- are discarded.  The default buffering mode when a handle is opened
 881 -- is implementation-dependent and may depend on the object which is
 882 -- attached to that handle.
 883
 884 hSetBuffering :: Handle -> BufferMode -> IO ()
 885 hSetBuffering handle mode =
 886   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 887   case haType handle_ of
 888     ClosedHandle -> ioe_closedHandle
 889     _ -> do
 890          {- Note:
 891             - we flush the old buffer regardless of whether
 892               the new buffer could fit the contents of the old buffer
 893               or not.
 894             - allow a handle's buffering to change even if IO has
 895               occurred (ANSI C spec. does not allow this, nor did
 896               the previous implementation of IO.hSetBuffering).
 897             - a non-standard extension is to allow the buffering
 898               of semi-closed handles to change [sof 6/98]
 899           -}
 900           flushBuffer handle_
 901
 902           let state = initBufferState (haType handle_)
 903           new_buf <-
 904             case mode of
 905                 -- we always have a 1-character read buffer for
 906                 -- unbuffered  handles: it's needed to
 907                 -- support hLookAhead.
 908               NoBuffering            -> allocateBuffer 1 ReadBuffer
 909               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 910               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 911               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 912                                       | otherwise -> allocateBuffer n state
 913           writeIORef (haBuffer handle_) new_buf
 914
 915           -- for input terminals we need to put the terminal into
 916           -- cooked or raw mode depending on the type of buffering.
 917           is_tty <- fdIsTTY (haFD handle_)
 918           when (is_tty && isReadableHandleType (haType handle_)) $
 919                 case mode of
 920                   NoBuffering -> setCooked (haFD handle_) False
 921                   _           -> setCooked (haFD handle_) True
 922
 923           -- throw away spare buffers, they might be the wrong size
 924           writeIORef (haBuffers handle_) BufferListNil
 925
 926           return (handle_{ haBufferMode = mode })
 927
 928 -- -----------------------------------------------------------------------------
 929 -- hFlush
 930
 931 -- The action `hFlush hdl' causes any items buffered for output
 932 -- in handle `hdl' to be sent immediately to the operating
 933 -- system.
 934
 935 hFlush :: Handle -> IO ()
 936 hFlush handle =
 937    wantWritableHandle "hFlush" handle $ \ handle_ -> do
 938    buf <- readIORef (haBuffer handle_)
 939    if bufferIsWritable buf && not (bufferEmpty buf)
 940         then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
 941                 writeIORef (haBuffer handle_) flushed_buf
 942         else return ()
 943
 944
 945 -- -----------------------------------------------------------------------------
 946 -- Repositioning Handles
 947
 948 data HandlePosn = HandlePosn Handle HandlePosition
 949
 950 instance Eq HandlePosn where
 951     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 952
 953 instance Show HandlePosn where
 954    showsPrec p (HandlePosn h pos) =
 955         showsPrec p h . showString " at position " . shows pos
 956
 957   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 958   -- We represent it as an Integer on the Haskell side, but
 959   -- cheat slightly in that hGetPosn calls upon a C helper
 960   -- that reports the position back via (merely) an Int.
 961 type HandlePosition = Integer
 962
 963 -- Computation `hGetPosn hdl' returns the current I/O position of
 964 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
 965 -- position of `hdl' to a previously obtained position `p'.
 966
 967 hGetPosn :: Handle -> IO HandlePosn
 968 hGetPosn handle =
 969     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
 970
 971 #if defined(mingw32_TARGET_OS)
 972         -- urgh, on Windows we have to worry about \n -> \r\n translation,
 973         -- so we can't easily calculate the file position using the
 974         -- current buffer size.  Just flush instead.
 975       flushBuffer handle_
 976 #endif
 977       let fd = fromIntegral (haFD handle_)
 978       posn <- fromIntegral `liftM`
 979                 throwErrnoIfMinus1Retry "hGetPosn"
 980                    (c_lseek fd 0 sEEK_CUR)
 981
 982       let ref = haBuffer handle_
 983       buf <- readIORef ref
 984
 985       let real_posn
 986            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
 987            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
 988 #     ifdef DEBUG_DUMP
 989       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
 990       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
 991 #     endif
 992       return (HandlePosn handle real_posn)
 993
 994
 995 hSetPosn :: HandlePosn -> IO ()
 996 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 997
 998 -- ---------------------------------------------------------------------------
 999 -- hSeek
1000
1001 {-
1002 The action `hSeek hdl mode i' sets the position of handle
1003 `hdl' depending on `mode'.  If `mode' is
1004
1005  * AbsoluteSeek - The position of `hdl' is set to `i'.
1006  * RelativeSeek - The position of `hdl' is set to offset `i' from
1007                   the current position.
1008  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
1009                   the end of the file.
1010
1011 Some handles may not be seekable (see `hIsSeekable'), or only
1012 support a subset of the possible positioning operations (e.g. it may
1013 only be possible to seek to the end of a tape, or to a positive
1014 offset from the beginning or current position).
1015
1016 It is not possible to set a negative I/O position, or for a physical
1017 file, an I/O position beyond the current end-of-file.
1018
1019 Note:
1020  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1021    seeking at or past EOF.
1022
1023  - we possibly deviate from the report on the issue of seeking within
1024    the buffer and whether to flush it or not.  The report isn't exactly
1025    clear here.
1026 -}
1027
1028 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
1029                     deriving (Eq, Ord, Ix, Enum, Read, Show)
1030
1031 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1032 hSeek handle mode offset =
1033     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1034 #   ifdef DEBUG_DUMP
1035     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1036 #   endif
1037     let ref = haBuffer handle_
1038     buf <- readIORef ref
1039     let r = bufRPtr buf
1040         w = bufWPtr buf
1041         fd = haFD handle_
1042
1043     let do_seek =
1044           throwErrnoIfMinus1Retry_ "hSeek"
1045             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1046
1047         whence :: CInt
1048         whence = case mode of
1049                    AbsoluteSeek -> sEEK_SET
1050                    RelativeSeek -> sEEK_CUR
1051                    SeekFromEnd  -> sEEK_END
1052
1053     if bufferIsWritable buf
1054         then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1055                 writeIORef ref new_buf
1056                 do_seek
1057         else do
1058
1059     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1060         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1061         else do
1062
1063     new_buf <- flushReadBuffer (haFD handle_) buf
1064     writeIORef ref new_buf
1065     do_seek
1066
1067 -- -----------------------------------------------------------------------------
1068 -- Handle Properties
1069
1070 -- A number of operations return information about the properties of a
1071 -- handle.  Each of these operations returns `True' if the handle has
1072 -- the specified property, and `False' otherwise.
1073
1074 hIsOpen :: Handle -> IO Bool
1075 hIsOpen handle =
1076     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1077     case haType handle_ of
1078       ClosedHandle         -> return False
1079       SemiClosedHandle     -> return False
1080       _                    -> return True
1081
1082 hIsClosed :: Handle -> IO Bool
1083 hIsClosed handle =
1084     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1085     case haType handle_ of
1086       ClosedHandle         -> return True
1087       _                    -> return False
1088
1089 {- not defined, nor exported, but mentioned
1090    here for documentation purposes:
1091
1092     hSemiClosed :: Handle -> IO Bool
1093     hSemiClosed h = do
1094        ho <- hIsOpen h
1095        hc <- hIsClosed h
1096        return (not (ho || hc))
1097 -}
1098
1099 hIsReadable :: Handle -> IO Bool
1100 hIsReadable (DuplexHandle _ _) = return True
1101 hIsReadable handle =
1102     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1103     case haType handle_ of
1104       ClosedHandle         -> ioe_closedHandle
1105       SemiClosedHandle     -> ioe_closedHandle
1106       htype                -> return (isReadableHandleType htype)
1107
1108 hIsWritable :: Handle -> IO Bool
1109 hIsWritable (DuplexHandle _ _) = return False
1110 hIsWritable handle =
1111     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1112     case haType handle_ of
1113       ClosedHandle         -> ioe_closedHandle
1114       SemiClosedHandle     -> ioe_closedHandle
1115       htype                -> return (isWritableHandleType htype)
1116
1117 -- Querying how a handle buffers its data:
1118
1119 hGetBuffering :: Handle -> IO BufferMode
1120 hGetBuffering handle =
1121     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1122     case haType handle_ of
1123       ClosedHandle         -> ioe_closedHandle
1124       _ ->
1125            -- We're being non-standard here, and allow the buffering
1126            -- of a semi-closed handle to be queried.   -- sof 6/98
1127           return (haBufferMode handle_)  -- could be stricter..
1128
1129 hIsSeekable :: Handle -> IO Bool
1130 hIsSeekable handle =
1131     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1132     case haType handle_ of
1133       ClosedHandle         -> ioe_closedHandle
1134       SemiClosedHandle     -> ioe_closedHandle
1135       AppendHandle         -> return False
1136       _                    -> do t <- fdType (haFD handle_)
1137                                  return (t == RegularFile
1138                                          && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
1139
1140 -- -----------------------------------------------------------------------------
1141 -- Changing echo status
1142
1143 -- Non-standard GHC extension is to allow the echoing status
1144 -- of a handles connected to terminals to be reconfigured:
1145
1146 hSetEcho :: Handle -> Bool -> IO ()
1147 hSetEcho handle on = do
1148     isT   <- hIsTerminalDevice handle
1149     if not isT
1150      then return ()
1151      else
1152       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1153       case haType handle_ of
1154          ClosedHandle -> ioe_closedHandle
1155          _            -> setEcho (haFD handle_) on
1156
1157 hGetEcho :: Handle -> IO Bool
1158 hGetEcho handle = do
1159     isT   <- hIsTerminalDevice handle
1160     if not isT
1161      then return False
1162      else
1163        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1164        case haType handle_ of
1165          ClosedHandle -> ioe_closedHandle
1166          _            -> getEcho (haFD handle_)
1167
1168 hIsTerminalDevice :: Handle -> IO Bool
1169 hIsTerminalDevice handle = do
1170     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1171      case haType handle_ of
1172        ClosedHandle -> ioe_closedHandle
1173        _            -> fdIsTTY (haFD handle_)
1174
1175 -- -----------------------------------------------------------------------------
1176 -- hSetBinaryMode
1177 hSetBinaryMode handle bin =
1178   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1179     do throwErrnoIfMinus1_ "hSetBinaryMode"
1180           (setmode (fromIntegral (haFD handle_)) bin)
1181        return handle_{haIsBin=bin}
1182
1183 foreign import "prel_setmode" setmode :: CInt -> Bool -> IO CInt
1184
1185 -- -----------------------------------------------------------------------------
1186 -- Miscellaneous
1187
1188 -- These three functions are meant to get things out of an IOError.
1189
1190 ioeGetFileName        :: IOError -> Maybe FilePath
1191 ioeGetErrorString     :: IOError -> String
1192 ioeGetHandle          :: IOError -> Maybe Handle
1193
1194 ioeGetHandle (IOException (IOError h _ _ _ _)) = h
1195 ioeGetHandle (UserError _) = Nothing
1196 ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
1197
1198 ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
1199 ioeGetErrorString (UserError str) = str
1200 ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
1201
1202 ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
1203 ioeGetFileName (UserError _) = Nothing
1204 ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
1205
1206 -- ---------------------------------------------------------------------------
1207 -- debugging
1208
1209 #ifdef DEBUG_DUMP
1210 puts :: String -> IO ()
1211 puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
1212                                      return ()
1213 #endif
1214
1215 -- wrappers to platform-specific constants:
1216 foreign import ccall "prel_bufsiz"   unsafe dEFAULT_BUFFER_SIZE :: Int
1217 foreign import ccall "prel_seek_cur" unsafe sEEK_CUR :: CInt
1218 foreign import ccall "prel_seek_set" unsafe sEEK_SET :: CInt
1219 foreign import ccall "prel_seek_end" unsafe sEEK_END :: CInt
1220 foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt
1221
1222