ghc/lib/std/PrelHandle.hs

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