GHC/Handle.hs

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