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.11 2001/06/29 12:45:39 simonmar Exp $
   8 --
   9 -- (c) The University of Glasgow, 1994-2001
  10 --
  11 -- This module defines the basic operations on I/O "handles".
  12
  13 module PrelHandle (
  14   withHandle, withHandle', withHandle_,
  15   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
  16
  17   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  18   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
  19   read_off,
  20
  21   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
  22
  23   stdin, stdout, stderr,
  24   IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
  25   hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
  26   hFlush,
  27
  28   hClose, hClose_help,
  29
  30   HandlePosn(..), hGetPosn, hSetPosn,
  31   SeekMode(..), hSeek,
  32
  33   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  34   hSetEcho, hGetEcho, hIsTerminalDevice,
  35   ioeGetFileName, ioeGetErrorString, ioeGetHandle,
  36
  37 #ifdef DEBUG_DUMP
  38   puts,
  39 #endif
  40
  41  ) where
  42
  43 #include "cbits/HsStd.h"
  44
  45 import Monad
  46
  47 import PrelBits
  48 import PrelPosix
  49 import PrelMarshalUtils
  50 import PrelCString
  51 import PrelCTypes
  52 import PrelCError
  53 import PrelReal
  54
  55 import PrelArr
  56 import PrelBase
  57 import PrelPtr
  58 import PrelRead         ( Read )
  59 import PrelList
  60 import PrelIOBase
  61 import PrelMaybe        ( Maybe(..) )
  62 import PrelException
  63 import PrelEnum
  64 import PrelNum          ( Integer(..), Num(..) )
  65 import PrelShow
  66 import PrelReal         ( toInteger )
  67
  68 import PrelConc
  69
  70 -- -----------------------------------------------------------------------------
  71 -- TODO:
  72
  73 -- hWaitForInput blocks (should use a timeout)
  74
  75 -- unbuffered hGetLine is a bit dodgy
  76
  77 -- hSetBuffering: can't change buffering on a stream,
  78 --      when the read buffer is non-empty? (no way to flush the buffer)
  79
  80 -- ---------------------------------------------------------------------------
  81 -- Are files opened by default in text or binary mode, if the user doesn't
  82 -- specify?
  83 dEFAULT_OPEN_IN_BINARY_MODE :: Bool
  84 dEFAULT_OPEN_IN_BINARY_MODE = False
  85
  86 -- Is seeking on text-mode handles allowed, or not?
  87 tEXT_MODE_SEEK_ALLOWED :: Bool
  88 #if defined(mingw32_TARGET_OS)
  89 tEXT_MODE_SEEK_ALLOWED = False
  90 #else
  91 tEXT_MODE_SEEK_ALLOWED = True
  92 #endif
  93
  94
  95 -- ---------------------------------------------------------------------------
  96 -- Creating a new handle
  97
  98 newFileHandle     :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
  99 newFileHandle finalizer hc = do
 100   m <- newMVar hc
 101   addMVarFinalizer m (finalizer m)
 102   return (FileHandle m)
 103
 104 -- ---------------------------------------------------------------------------
 105 -- Working with Handles
 106
 107 {-
 108 In the concurrent world, handles are locked during use.  This is done
 109 by wrapping an MVar around the handle which acts as a mutex over
 110 operations on the handle.
 111
 112 To avoid races, we use the following bracketing operations.  The idea
 113 is to obtain the lock, do some operation and replace the lock again,
 114 whether the operation succeeded or failed.  We also want to handle the
 115 case where the thread receives an exception while processing the IO
 116 operation: in these cases we also want to relinquish the lock.
 117
 118 There are three versions of @withHandle@: corresponding to the three
 119 possible combinations of:
 120
 121         - the operation may side-effect the handle
 122         - the operation may return a result
 123
 124 If the operation generates an error or an exception is raised, the
 125 original handle is always replaced [ this is the case at the moment,
 126 but we might want to revisit this in the future --SDM ].
 127 -}
 128
 129 {-# INLINE withHandle #-}
 130 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 131 withHandle fun h@(FileHandle m)     act = withHandle' fun h m act
 132 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m 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 = withHandle__' "hClose" h m $ hClose_help
 768
 769 hClose_help handle_ =
 770   case haType handle_ of
 771       ClosedHandle -> return handle_
 772       _ -> do
 773           let fd = fromIntegral (haFD handle_)
 774           flushWriteBufferOnly handle_
 775           throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
 776
 777           -- free the spare buffers
 778           writeIORef (haBuffers handle_) BufferListNil
 779
 780           -- unlock it
 781           unlockFile fd
 782
 783           -- we must set the fd to -1, because the finalizer is going
 784           -- to run eventually and try to close/unlock it.
 785           return (handle_{ haFD        = -1,
 786                            haType      = ClosedHandle
 787                          })
 788
 789 -----------------------------------------------------------------------------
 790 -- Detecting the size of a file
 791
 792 -- For a handle `hdl' which attached to a physical file, `hFileSize
 793 -- hdl' returns the size of `hdl' in terms of the number of items
 794 -- which can be read from `hdl'.
 795
 796 hFileSize :: Handle -> IO Integer
 797 hFileSize handle =
 798     withHandle_ "hFileSize" handle $ \ handle_ -> do
 799     case haType handle_ of
 800       ClosedHandle              -> ioe_closedHandle
 801       SemiClosedHandle          -> ioe_closedHandle
 802       _ -> do flushWriteBufferOnly handle_
 803               r <- fdFileSize (haFD handle_)
 804               if r /= -1
 805                  then return r
 806                  else ioException (IOError Nothing InappropriateType "hFileSize"
 807                                    "not a regular file" Nothing)
 808
 809 -- ---------------------------------------------------------------------------
 810 -- Detecting the End of Input
 811
 812 -- For a readable handle `hdl', `hIsEOF hdl' returns
 813 -- `True' if no further input can be taken from `hdl' or for a
 814 -- physical file, if the current I/O position is equal to the length of
 815 -- the file.  Otherwise, it returns `False'.
 816
 817 hIsEOF :: Handle -> IO Bool
 818 hIsEOF handle =
 819   catch
 820      (do hLookAhead handle; return False)
 821      (\e -> if isEOFError e then return True else throw e)
 822
 823 isEOF :: IO Bool
 824 isEOF = hIsEOF stdin
 825
 826 -- ---------------------------------------------------------------------------
 827 -- Looking ahead
 828
 829 -- hLookahead returns the next character from the handle without
 830 -- removing it from the input buffer, blocking until a character is
 831 -- available.
 832
 833 hLookAhead :: Handle -> IO Char
 834 hLookAhead handle = do
 835   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 836   let ref     = haBuffer handle_
 837       fd      = haFD handle_
 838       is_line = haBufferMode handle_ == LineBuffering
 839   buf <- readIORef ref
 840
 841   -- fill up the read buffer if necessary
 842   new_buf <- if bufferEmpty buf
 843                 then fillReadBuffer fd is_line buf
 844                 else return buf
 845
 846   writeIORef ref new_buf
 847
 848   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 849   return c
 850
 851 -- ---------------------------------------------------------------------------
 852 -- Buffering Operations
 853
 854 -- Three kinds of buffering are supported: line-buffering,
 855 -- block-buffering or no-buffering.  See PrelIOBase for definition and
 856 -- further explanation of what the type represent.
 857
 858 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 859 -- handle hdl on subsequent reads and writes.
 860 --
 861 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 862 --
 863 --   * If mode is `BlockBuffering size', then block-buffering
 864 --     should be enabled if possible.  The size of the buffer is n items
 865 --     if size is `Just n' and is otherwise implementation-dependent.
 866 --
 867 --   * If mode is NoBuffering, then buffering is disabled if possible.
 868
 869 -- If the buffer mode is changed from BlockBuffering or
 870 -- LineBuffering to NoBuffering, then any items in the output
 871 -- buffer are written to the device, and any items in the input buffer
 872 -- are discarded.  The default buffering mode when a handle is opened
 873 -- is implementation-dependent and may depend on the object which is
 874 -- attached to that handle.
 875
 876 hSetBuffering :: Handle -> BufferMode -> IO ()
 877 hSetBuffering handle mode =
 878   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 879   case haType handle_ of
 880     ClosedHandle -> ioe_closedHandle
 881     _ -> do
 882          {- Note:
 883             - we flush the old buffer regardless of whether
 884               the new buffer could fit the contents of the old buffer
 885               or not.
 886             - allow a handle's buffering to change even if IO has
 887               occurred (ANSI C spec. does not allow this, nor did
 888               the previous implementation of IO.hSetBuffering).
 889             - a non-standard extension is to allow the buffering
 890               of semi-closed handles to change [sof 6/98]
 891           -}
 892           flushBuffer handle_
 893
 894           let state = initBufferState (haType handle_)
 895           new_buf <-
 896             case mode of
 897                 -- we always have a 1-character read buffer for
 898                 -- unbuffered  handles: it's needed to
 899                 -- support hLookAhead.
 900               NoBuffering            -> allocateBuffer 1 ReadBuffer
 901               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 902               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 903               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 904                                       | otherwise -> allocateBuffer n state
 905           writeIORef (haBuffer handle_) new_buf
 906
 907           -- for input terminals we need to put the terminal into
 908           -- cooked or raw mode depending on the type of buffering.
 909           is_tty <- fdIsTTY (haFD handle_)
 910           when (is_tty && isReadableHandleType (haType handle_)) $
 911                 case mode of
 912                   NoBuffering -> setCooked (haFD handle_) False
 913                   _           -> setCooked (haFD handle_) True
 914
 915           -- throw away spare buffers, they might be the wrong size
 916           writeIORef (haBuffers handle_) BufferListNil
 917
 918           return (handle_{ haBufferMode = mode })
 919
 920 -- -----------------------------------------------------------------------------
 921 -- hFlush
 922
 923 -- The action `hFlush hdl' causes any items buffered for output
 924 -- in handle `hdl' to be sent immediately to the operating
 925 -- system.
 926
 927 hFlush :: Handle -> IO ()
 928 hFlush handle =
 929    wantWritableHandle "hFlush" handle $ \ handle_ -> do
 930    buf <- readIORef (haBuffer handle_)
 931    if bufferIsWritable buf && not (bufferEmpty buf)
 932         then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
 933                 writeIORef (haBuffer handle_) flushed_buf
 934         else return ()
 935
 936
 937 -- -----------------------------------------------------------------------------
 938 -- Repositioning Handles
 939
 940 data HandlePosn = HandlePosn Handle HandlePosition
 941
 942 instance Eq HandlePosn where
 943     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 944
 945   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 946   -- We represent it as an Integer on the Haskell side, but
 947   -- cheat slightly in that hGetPosn calls upon a C helper
 948   -- that reports the position back via (merely) an Int.
 949 type HandlePosition = Integer
 950
 951 -- Computation `hGetPosn hdl' returns the current I/O position of
 952 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
 953 -- position of `hdl' to a previously obtained position `p'.
 954
 955 hGetPosn :: Handle -> IO HandlePosn
 956 hGetPosn handle =
 957     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
 958
 959 #if defined(_WIN32)
 960         -- urgh, on Windows we have to worry about \n -> \r\n translation,
 961         -- so we can't easily calculate the file position using the
 962         -- current buffer size.  Just flush instead.
 963       flushBuffer handle_
 964 #endif
 965       let fd = fromIntegral (haFD handle_)
 966       posn <- fromIntegral `liftM`
 967                 throwErrnoIfMinus1Retry "hGetPosn"
 968                    (c_lseek fd 0 (#const SEEK_CUR))
 969
 970       let ref = haBuffer handle_
 971       buf <- readIORef ref
 972
 973       let real_posn
 974            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
 975            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
 976 #     ifdef DEBUG_DUMP
 977       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
 978       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
 979 #     endif
 980       return (HandlePosn handle real_posn)
 981
 982
 983 hSetPosn :: HandlePosn -> IO ()
 984 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 985
 986 -- ---------------------------------------------------------------------------
 987 -- hSeek
 988
 989 {-
 990 The action `hSeek hdl mode i' sets the position of handle
 991 `hdl' depending on `mode'.  If `mode' is
 992
 993  * AbsoluteSeek - The position of `hdl' is set to `i'.
 994  * RelativeSeek - The position of `hdl' is set to offset `i' from
 995                   the current position.
 996  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
 997                   the end of the file.
 998
 999 Some handles may not be seekable (see `hIsSeekable'), or only
1000 support a subset of the possible positioning operations (e.g. it may
1001 only be possible to seek to the end of a tape, or to a positive
1002 offset from the beginning or current position).
1003
1004 It is not possible to set a negative I/O position, or for a physical
1005 file, an I/O position beyond the current end-of-file.
1006
1007 Note:
1008  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1009    seeking at or past EOF.
1010
1011  - we possibly deviate from the report on the issue of seeking within
1012    the buffer and whether to flush it or not.  The report isn't exactly
1013    clear here.
1014 -}
1015
1016 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
1017                     deriving (Eq, Ord, Ix, Enum, Read, Show)
1018
1019 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1020 hSeek handle mode offset =
1021     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1022 #   ifdef DEBUG_DUMP
1023     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1024 #   endif
1025     let ref = haBuffer handle_
1026     buf <- readIORef ref
1027     let r = bufRPtr buf
1028         w = bufWPtr buf
1029         fd = haFD handle_
1030
1031     let do_seek =
1032           throwErrnoIfMinus1Retry_ "hSeek"
1033             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1034
1035         whence :: CInt
1036         whence = case mode of
1037                    AbsoluteSeek -> (#const SEEK_SET)
1038                    RelativeSeek -> (#const SEEK_CUR)
1039                    SeekFromEnd  -> (#const SEEK_END)
1040
1041     if bufferIsWritable buf
1042         then do new_buf <- flushWriteBuffer fd buf
1043                 writeIORef ref new_buf
1044                 do_seek
1045         else do
1046
1047     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1048         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1049         else do
1050
1051     new_buf <- flushReadBuffer (haFD handle_) buf
1052     writeIORef ref new_buf
1053     do_seek
1054
1055 -- -----------------------------------------------------------------------------
1056 -- Handle Properties
1057
1058 -- A number of operations return information about the properties of a
1059 -- handle.  Each of these operations returns `True' if the handle has
1060 -- the specified property, and `False' otherwise.
1061
1062 hIsOpen :: Handle -> IO Bool
1063 hIsOpen handle =
1064     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1065     case haType handle_ of
1066       ClosedHandle         -> return False
1067       SemiClosedHandle     -> return False
1068       _                    -> return True
1069
1070 hIsClosed :: Handle -> IO Bool
1071 hIsClosed handle =
1072     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1073     case haType handle_ of
1074       ClosedHandle         -> return True
1075       _                    -> return False
1076
1077 {- not defined, nor exported, but mentioned
1078    here for documentation purposes:
1079
1080     hSemiClosed :: Handle -> IO Bool
1081     hSemiClosed h = do
1082        ho <- hIsOpen h
1083        hc <- hIsClosed h
1084        return (not (ho || hc))
1085 -}
1086
1087 hIsReadable :: Handle -> IO Bool
1088 hIsReadable (DuplexHandle _ _) = return True
1089 hIsReadable handle =
1090     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1091     case haType handle_ of
1092       ClosedHandle         -> ioe_closedHandle
1093       SemiClosedHandle     -> ioe_closedHandle
1094       htype                -> return (isReadableHandleType htype)
1095
1096 hIsWritable :: Handle -> IO Bool
1097 hIsWritable (DuplexHandle _ _) = return False
1098 hIsWritable handle =
1099     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1100     case haType handle_ of
1101       ClosedHandle         -> ioe_closedHandle
1102       SemiClosedHandle     -> ioe_closedHandle
1103       htype                -> return (isWritableHandleType htype)
1104
1105 -- Querying how a handle buffers its data:
1106
1107 hGetBuffering :: Handle -> IO BufferMode
1108 hGetBuffering handle =
1109     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1110     case haType handle_ of
1111       ClosedHandle         -> ioe_closedHandle
1112       _ ->
1113            -- We're being non-standard here, and allow the buffering
1114            -- of a semi-closed handle to be queried.   -- sof 6/98
1115           return (haBufferMode handle_)  -- could be stricter..
1116
1117 hIsSeekable :: Handle -> IO Bool
1118 hIsSeekable handle =
1119     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1120     case haType handle_ of
1121       ClosedHandle         -> ioe_closedHandle
1122       SemiClosedHandle     -> ioe_closedHandle
1123       AppendHandle         -> return False
1124       _                    -> do t <- fdType (haFD handle_)
1125                                  return (t == RegularFile
1126                                          && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
1127
1128 -- -----------------------------------------------------------------------------
1129 -- Changing echo status
1130
1131 -- Non-standard GHC extension is to allow the echoing status
1132 -- of a handles connected to terminals to be reconfigured:
1133
1134 hSetEcho :: Handle -> Bool -> IO ()
1135 hSetEcho handle on = do
1136     isT   <- hIsTerminalDevice handle
1137     if not isT
1138      then return ()
1139      else
1140       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1141       case haType handle_ of
1142          ClosedHandle -> ioe_closedHandle
1143          _            -> setEcho (haFD handle_) on
1144
1145 hGetEcho :: Handle -> IO Bool
1146 hGetEcho handle = do
1147     isT   <- hIsTerminalDevice handle
1148     if not isT
1149      then return False
1150      else
1151        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1152        case haType handle_ of
1153          ClosedHandle -> ioe_closedHandle
1154          _            -> getEcho (haFD handle_)
1155
1156 hIsTerminalDevice :: Handle -> IO Bool
1157 hIsTerminalDevice handle = do
1158     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1159      case haType handle_ of
1160        ClosedHandle -> ioe_closedHandle
1161        _            -> fdIsTTY (haFD handle_)
1162
1163 -- -----------------------------------------------------------------------------
1164 -- hSetBinaryMode
1165
1166 #ifdef _WIN32
1167 hSetBinaryMode handle bin =
1168   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1169     do let flg | bin       = (#const O_BINARY)
1170                | otherwise = (#const O_TEXT)
1171        throwErrnoIfMinus1_ "hSetBinaryMode"
1172           (setmode (fromIntegral (haFD handle_)) flg)
1173        return handle_{haIsBin=bin}
1174   return ()
1175
1176 foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
1177 #else
1178 hSetBinaryMode handle bin = do
1179   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1180     return handle_{haIsBin=bin}
1181   return ()
1182 #endif
1183
1184 -- -----------------------------------------------------------------------------
1185 -- Miscellaneous
1186
1187 -- These three functions are meant to get things out of an IOError.
1188
1189 ioeGetFileName        :: IOError -> Maybe FilePath
1190 ioeGetErrorString     :: IOError -> String
1191 ioeGetHandle          :: IOError -> Maybe Handle
1192
1193 ioeGetHandle (IOException (IOError h _ _ _ _)) = h
1194 ioeGetHandle (UserError _) = Nothing
1195 ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
1196
1197 ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
1198 ioeGetErrorString (UserError str) = str
1199 ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
1200
1201 ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
1202 ioeGetFileName (UserError _) = Nothing
1203 ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
1204
1205 -- ---------------------------------------------------------------------------
1206 -- debugging
1207
1208 #ifdef DEBUG_DUMP
1209 puts :: String -> IO ()
1210 puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
1211                                      return ()
1212 #endif