ghc/lib/std/PrelHandle.hsc

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