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.15 2001/07/13 15:01:28 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 "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       truncate | WriteMode <- mode = True
 630                | otherwise         = False
 631
 632       binary_flags
 633 #ifdef HAVE_O_BINARY
 634           | binary    = o_BINARY
 635 #endif
 636           | otherwise = 0
 637
 638       oflags = oflags1 .|. binary_flags
 639     in do
 640
 641     -- the old implementation had a complicated series of three opens,
 642     -- which is perhaps because we have to be careful not to open
 643     -- directories.  However, the man pages I've read say that open()
 644     -- always returns EISDIR if the file is a directory and was opened
 645     -- for writing, so I think we're ok with a single open() here...
 646     fd <- fromIntegral `liftM`
 647               throwErrnoIfMinus1Retry "openFile"
 648                 (c_open f (fromIntegral oflags) 0o666)
 649
 650     openFd fd filepath mode binary truncate
 651         -- ASSERT: if we just created the file, then openFd won't fail
 652         -- (so we don't need to worry about removing the newly created file
 653         --  in the event of an error).
 654
 655
 656 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 657 output_flags = std_flags    .|. o_CREAT
 658 read_flags   = std_flags    .|. o_RDONLY
 659 write_flags  = output_flags .|. o_WRONLY
 660 rw_flags     = output_flags .|. o_RDWR
 661 append_flags = write_flags  .|. o_APPEND
 662
 663 -- ---------------------------------------------------------------------------
 664 -- openFd
 665
 666 openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
 667 openFd fd filepath mode binary truncate = do
 668     -- turn on non-blocking mode
 669     setNonBlockingFD fd
 670
 671     let (ha_type, write) =
 672           case mode of
 673             ReadMode      -> ( ReadHandle,      False )
 674             WriteMode     -> ( WriteHandle,     True )
 675             ReadWriteMode -> ( ReadWriteHandle, True )
 676             AppendMode    -> ( AppendHandle,    True )
 677
 678     -- open() won't tell us if it was a directory if we only opened for
 679     -- reading, so check again.
 680     fd_type <- fdType fd
 681     case fd_type of
 682         Directory ->
 683            ioException (IOError Nothing InappropriateType "openFile"
 684                            "is a directory" Nothing)
 685
 686         Stream
 687            | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
 688            | otherwise                  -> mkFileHandle fd filepath ha_type binary
 689
 690         -- regular files need to be locked
 691         RegularFile -> do
 692            r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 693            when (r == -1)  $
 694                 ioException (IOError Nothing ResourceBusy "openFile"
 695                                    "file is locked" Nothing)
 696
 697            -- truncate the file if necessary
 698            when truncate (fileTruncate filepath)
 699
 700            mkFileHandle fd filepath ha_type binary
 701
 702
 703 foreign import "lockFile" unsafe
 704   lockFile :: CInt -> CInt -> CInt -> IO CInt
 705
 706 foreign import "unlockFile" unsafe
 707   unlockFile :: CInt -> IO CInt
 708
 709 mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
 710 mkFileHandle fd filepath ha_type binary = do
 711   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 712   spares <- newIORef BufferListNil
 713   newFileHandle handleFinalizer
 714             (Handle__ { haFD = fd,
 715                         haType = ha_type,
 716                         haIsBin = binary,
 717                         haBufferMode = bmode,
 718                         haFilePath = filepath,
 719                         haBuffer = buf,
 720                         haBuffers = spares
 721                       })
 722
 723 mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
 724 mkDuplexHandle fd filepath binary = do
 725   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 726   w_spares <- newIORef BufferListNil
 727   let w_handle_ =
 728              Handle__ { haFD = fd,
 729                         haType = WriteHandle,
 730                         haIsBin = binary,
 731                         haBufferMode = w_bmode,
 732                         haFilePath = filepath,
 733                         haBuffer = w_buf,
 734                         haBuffers = w_spares
 735                       }
 736   write_side <- newMVar w_handle_
 737
 738   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 739   r_spares <- newIORef BufferListNil
 740   let r_handle_ =
 741              Handle__ { haFD = fd,
 742                         haType = ReadSideHandle write_side,
 743                         haIsBin = binary,
 744                         haBufferMode = r_bmode,
 745                         haFilePath = filepath,
 746                         haBuffer = r_buf,
 747                         haBuffers = r_spares
 748                       }
 749   read_side <- newMVar r_handle_
 750
 751   addMVarFinalizer write_side (handleFinalizer write_side)
 752   return (DuplexHandle read_side write_side)
 753
 754
 755 initBufferState ReadHandle = ReadBuffer
 756 initBufferState _          = WriteBuffer
 757
 758 -- ---------------------------------------------------------------------------
 759 -- Closing a handle
 760
 761 -- Computation `hClose hdl' makes handle `hdl' closed.  Before the
 762 -- computation finishes, any items buffered for output and not already
 763 -- sent to the operating system are flushed as for `hFlush'.
 764
 765 -- For a duplex handle, we close&flush the write side, and just close
 766 -- the read side.
 767
 768 hClose :: Handle -> IO ()
 769 hClose h@(FileHandle m)     = hClose' h m
 770 hClose h@(DuplexHandle r w) = do
 771   hClose' h w
 772   withHandle__' "hClose" h r $ \ handle_ -> do
 773   return handle_{ haFD   = -1,
 774                   haType = ClosedHandle
 775                  }
 776
 777 hClose' h m = withHandle__' "hClose" h m $ hClose_help
 778
 779 hClose_help handle_ =
 780   case haType handle_ of
 781       ClosedHandle -> return handle_
 782       _ -> do
 783           let fd = fromIntegral (haFD handle_)
 784           flushWriteBufferOnly handle_
 785           throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
 786
 787           -- free the spare buffers
 788           writeIORef (haBuffers handle_) BufferListNil
 789
 790           -- unlock it
 791           unlockFile fd
 792
 793           -- we must set the fd to -1, because the finalizer is going
 794           -- to run eventually and try to close/unlock it.
 795           return (handle_{ haFD        = -1,
 796                            haType      = ClosedHandle
 797                          })
 798
 799 -----------------------------------------------------------------------------
 800 -- Detecting the size of a file
 801
 802 -- For a handle `hdl' which attached to a physical file, `hFileSize
 803 -- hdl' returns the size of `hdl' in terms of the number of items
 804 -- which can be read from `hdl'.
 805
 806 hFileSize :: Handle -> IO Integer
 807 hFileSize handle =
 808     withHandle_ "hFileSize" handle $ \ handle_ -> do
 809     case haType handle_ of
 810       ClosedHandle              -> ioe_closedHandle
 811       SemiClosedHandle          -> ioe_closedHandle
 812       _ -> do flushWriteBufferOnly handle_
 813               r <- fdFileSize (haFD handle_)
 814               if r /= -1
 815                  then return r
 816                  else ioException (IOError Nothing InappropriateType "hFileSize"
 817                                    "not a regular file" Nothing)
 818
 819 -- ---------------------------------------------------------------------------
 820 -- Detecting the End of Input
 821
 822 -- For a readable handle `hdl', `hIsEOF hdl' returns
 823 -- `True' if no further input can be taken from `hdl' or for a
 824 -- physical file, if the current I/O position is equal to the length of
 825 -- the file.  Otherwise, it returns `False'.
 826
 827 hIsEOF :: Handle -> IO Bool
 828 hIsEOF handle =
 829   catch
 830      (do hLookAhead handle; return False)
 831      (\e -> if isEOFError e then return True else throw e)
 832
 833 isEOF :: IO Bool
 834 isEOF = hIsEOF stdin
 835
 836 -- ---------------------------------------------------------------------------
 837 -- Looking ahead
 838
 839 -- hLookahead returns the next character from the handle without
 840 -- removing it from the input buffer, blocking until a character is
 841 -- available.
 842
 843 hLookAhead :: Handle -> IO Char
 844 hLookAhead handle = do
 845   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 846   let ref     = haBuffer handle_
 847       fd      = haFD handle_
 848       is_line = haBufferMode handle_ == LineBuffering
 849   buf <- readIORef ref
 850
 851   -- fill up the read buffer if necessary
 852   new_buf <- if bufferEmpty buf
 853                 then fillReadBuffer fd is_line buf
 854                 else return buf
 855
 856   writeIORef ref new_buf
 857
 858   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 859   return c
 860
 861 -- ---------------------------------------------------------------------------
 862 -- Buffering Operations
 863
 864 -- Three kinds of buffering are supported: line-buffering,
 865 -- block-buffering or no-buffering.  See PrelIOBase for definition and
 866 -- further explanation of what the type represent.
 867
 868 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 869 -- handle hdl on subsequent reads and writes.
 870 --
 871 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 872 --
 873 --   * If mode is `BlockBuffering size', then block-buffering
 874 --     should be enabled if possible.  The size of the buffer is n items
 875 --     if size is `Just n' and is otherwise implementation-dependent.
 876 --
 877 --   * If mode is NoBuffering, then buffering is disabled if possible.
 878
 879 -- If the buffer mode is changed from BlockBuffering or
 880 -- LineBuffering to NoBuffering, then any items in the output
 881 -- buffer are written to the device, and any items in the input buffer
 882 -- are discarded.  The default buffering mode when a handle is opened
 883 -- is implementation-dependent and may depend on the object which is
 884 -- attached to that handle.
 885
 886 hSetBuffering :: Handle -> BufferMode -> IO ()
 887 hSetBuffering handle mode =
 888   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 889   case haType handle_ of
 890     ClosedHandle -> ioe_closedHandle
 891     _ -> do
 892          {- Note:
 893             - we flush the old buffer regardless of whether
 894               the new buffer could fit the contents of the old buffer
 895               or not.
 896             - allow a handle's buffering to change even if IO has
 897               occurred (ANSI C spec. does not allow this, nor did
 898               the previous implementation of IO.hSetBuffering).
 899             - a non-standard extension is to allow the buffering
 900               of semi-closed handles to change [sof 6/98]
 901           -}
 902           flushBuffer handle_
 903
 904           let state = initBufferState (haType handle_)
 905           new_buf <-
 906             case mode of
 907                 -- we always have a 1-character read buffer for
 908                 -- unbuffered  handles: it's needed to
 909                 -- support hLookAhead.
 910               NoBuffering            -> allocateBuffer 1 ReadBuffer
 911               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 912               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 913               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 914                                       | otherwise -> allocateBuffer n state
 915           writeIORef (haBuffer handle_) new_buf
 916
 917           -- for input terminals we need to put the terminal into
 918           -- cooked or raw mode depending on the type of buffering.
 919           is_tty <- fdIsTTY (haFD handle_)
 920           when (is_tty && isReadableHandleType (haType handle_)) $
 921                 case mode of
 922                   NoBuffering -> setCooked (haFD handle_) False
 923                   _           -> setCooked (haFD handle_) True
 924
 925           -- throw away spare buffers, they might be the wrong size
 926           writeIORef (haBuffers handle_) BufferListNil
 927
 928           return (handle_{ haBufferMode = mode })
 929
 930 -- -----------------------------------------------------------------------------
 931 -- hFlush
 932
 933 -- The action `hFlush hdl' causes any items buffered for output
 934 -- in handle `hdl' to be sent immediately to the operating
 935 -- system.
 936
 937 hFlush :: Handle -> IO ()
 938 hFlush handle =
 939    wantWritableHandle "hFlush" handle $ \ handle_ -> do
 940    buf <- readIORef (haBuffer handle_)
 941    if bufferIsWritable buf && not (bufferEmpty buf)
 942         then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
 943                 writeIORef (haBuffer handle_) flushed_buf
 944         else return ()
 945
 946
 947 -- -----------------------------------------------------------------------------
 948 -- Repositioning Handles
 949
 950 data HandlePosn = HandlePosn Handle HandlePosition
 951
 952 instance Eq HandlePosn where
 953     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 954
 955   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 956   -- We represent it as an Integer on the Haskell side, but
 957   -- cheat slightly in that hGetPosn calls upon a C helper
 958   -- that reports the position back via (merely) an Int.
 959 type HandlePosition = Integer
 960
 961 -- Computation `hGetPosn hdl' returns the current I/O position of
 962 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
 963 -- position of `hdl' to a previously obtained position `p'.
 964
 965 hGetPosn :: Handle -> IO HandlePosn
 966 hGetPosn handle =
 967     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
 968
 969 #if defined(_WIN32)
 970         -- urgh, on Windows we have to worry about \n -> \r\n translation,
 971         -- so we can't easily calculate the file position using the
 972         -- current buffer size.  Just flush instead.
 973       flushBuffer handle_
 974 #endif
 975       let fd = fromIntegral (haFD handle_)
 976       posn <- fromIntegral `liftM`
 977                 throwErrnoIfMinus1Retry "hGetPosn"
 978                    (c_lseek fd 0 (#const SEEK_CUR))
 979
 980       let ref = haBuffer handle_
 981       buf <- readIORef ref
 982
 983       let real_posn
 984            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
 985            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
 986 #     ifdef DEBUG_DUMP
 987       puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
 988       puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
 989 #     endif
 990       return (HandlePosn handle real_posn)
 991
 992
 993 hSetPosn :: HandlePosn -> IO ()
 994 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 995
 996 -- ---------------------------------------------------------------------------
 997 -- hSeek
 998
 999 {-
1000 The action `hSeek hdl mode i' sets the position of handle
1001 `hdl' depending on `mode'.  If `mode' is
1002
1003  * AbsoluteSeek - The position of `hdl' is set to `i'.
1004  * RelativeSeek - The position of `hdl' is set to offset `i' from
1005                   the current position.
1006  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
1007                   the end of the file.
1008
1009 Some handles may not be seekable (see `hIsSeekable'), or only
1010 support a subset of the possible positioning operations (e.g. it may
1011 only be possible to seek to the end of a tape, or to a positive
1012 offset from the beginning or current position).
1013
1014 It is not possible to set a negative I/O position, or for a physical
1015 file, an I/O position beyond the current end-of-file.
1016
1017 Note:
1018  - when seeking using `SeekFromEnd', positive offsets (>=0) means
1019    seeking at or past EOF.
1020
1021  - we possibly deviate from the report on the issue of seeking within
1022    the buffer and whether to flush it or not.  The report isn't exactly
1023    clear here.
1024 -}
1025
1026 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
1027                     deriving (Eq, Ord, Ix, Enum, Read, Show)
1028
1029 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1030 hSeek handle mode offset =
1031     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1032 #   ifdef DEBUG_DUMP
1033     puts ("hSeek " ++ show (mode,offset) ++ "\n")
1034 #   endif
1035     let ref = haBuffer handle_
1036     buf <- readIORef ref
1037     let r = bufRPtr buf
1038         w = bufWPtr buf
1039         fd = haFD handle_
1040
1041     let do_seek =
1042           throwErrnoIfMinus1Retry_ "hSeek"
1043             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1044
1045         whence :: CInt
1046         whence = case mode of
1047                    AbsoluteSeek -> (#const SEEK_SET)
1048                    RelativeSeek -> (#const SEEK_CUR)
1049                    SeekFromEnd  -> (#const SEEK_END)
1050
1051     if bufferIsWritable buf
1052         then do new_buf <- flushWriteBuffer fd buf
1053                 writeIORef ref new_buf
1054                 do_seek
1055         else do
1056
1057     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1058         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1059         else do
1060
1061     new_buf <- flushReadBuffer (haFD handle_) buf
1062     writeIORef ref new_buf
1063     do_seek
1064
1065 -- -----------------------------------------------------------------------------
1066 -- Handle Properties
1067
1068 -- A number of operations return information about the properties of a
1069 -- handle.  Each of these operations returns `True' if the handle has
1070 -- the specified property, and `False' otherwise.
1071
1072 hIsOpen :: Handle -> IO Bool
1073 hIsOpen handle =
1074     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1075     case haType handle_ of
1076       ClosedHandle         -> return False
1077       SemiClosedHandle     -> return False
1078       _                    -> return True
1079
1080 hIsClosed :: Handle -> IO Bool
1081 hIsClosed handle =
1082     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1083     case haType handle_ of
1084       ClosedHandle         -> return True
1085       _                    -> return False
1086
1087 {- not defined, nor exported, but mentioned
1088    here for documentation purposes:
1089
1090     hSemiClosed :: Handle -> IO Bool
1091     hSemiClosed h = do
1092        ho <- hIsOpen h
1093        hc <- hIsClosed h
1094        return (not (ho || hc))
1095 -}
1096
1097 hIsReadable :: Handle -> IO Bool
1098 hIsReadable (DuplexHandle _ _) = return True
1099 hIsReadable handle =
1100     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1101     case haType handle_ of
1102       ClosedHandle         -> ioe_closedHandle
1103       SemiClosedHandle     -> ioe_closedHandle
1104       htype                -> return (isReadableHandleType htype)
1105
1106 hIsWritable :: Handle -> IO Bool
1107 hIsWritable (DuplexHandle _ _) = return False
1108 hIsWritable handle =
1109     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1110     case haType handle_ of
1111       ClosedHandle         -> ioe_closedHandle
1112       SemiClosedHandle     -> ioe_closedHandle
1113       htype                -> return (isWritableHandleType htype)
1114
1115 -- Querying how a handle buffers its data:
1116
1117 hGetBuffering :: Handle -> IO BufferMode
1118 hGetBuffering handle =
1119     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1120     case haType handle_ of
1121       ClosedHandle         -> ioe_closedHandle
1122       _ ->
1123            -- We're being non-standard here, and allow the buffering
1124            -- of a semi-closed handle to be queried.   -- sof 6/98
1125           return (haBufferMode handle_)  -- could be stricter..
1126
1127 hIsSeekable :: Handle -> IO Bool
1128 hIsSeekable handle =
1129     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1130     case haType handle_ of
1131       ClosedHandle         -> ioe_closedHandle
1132       SemiClosedHandle     -> ioe_closedHandle
1133       AppendHandle         -> return False
1134       _                    -> do t <- fdType (haFD handle_)
1135                                  return (t == RegularFile
1136                                          && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
1137
1138 -- -----------------------------------------------------------------------------
1139 -- Changing echo status
1140
1141 -- Non-standard GHC extension is to allow the echoing status
1142 -- of a handles connected to terminals to be reconfigured:
1143
1144 hSetEcho :: Handle -> Bool -> IO ()
1145 hSetEcho handle on = do
1146     isT   <- hIsTerminalDevice handle
1147     if not isT
1148      then return ()
1149      else
1150       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1151       case haType handle_ of
1152          ClosedHandle -> ioe_closedHandle
1153          _            -> setEcho (haFD handle_) on
1154
1155 hGetEcho :: Handle -> IO Bool
1156 hGetEcho handle = do
1157     isT   <- hIsTerminalDevice handle
1158     if not isT
1159      then return False
1160      else
1161        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1162        case haType handle_ of
1163          ClosedHandle -> ioe_closedHandle
1164          _            -> getEcho (haFD handle_)
1165
1166 hIsTerminalDevice :: Handle -> IO Bool
1167 hIsTerminalDevice handle = do
1168     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1169      case haType handle_ of
1170        ClosedHandle -> ioe_closedHandle
1171        _            -> fdIsTTY (haFD handle_)
1172
1173 -- -----------------------------------------------------------------------------
1174 -- hSetBinaryMode
1175
1176 #ifdef _WIN32
1177 hSetBinaryMode handle bin =
1178   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1179     do let flg | bin       = (#const O_BINARY)
1180                | otherwise = (#const O_TEXT)
1181        throwErrnoIfMinus1_ "hSetBinaryMode"
1182           (setmode (fromIntegral (haFD handle_)) flg)
1183        return handle_{haIsBin=bin}
1184
1185 foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
1186 #else
1187 hSetBinaryMode handle bin =
1188   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1189     return handle_{haIsBin=bin}
1190 #endif
1191
1192 -- -----------------------------------------------------------------------------
1193 -- Miscellaneous
1194
1195 -- These three functions are meant to get things out of an IOError.
1196
1197 ioeGetFileName        :: IOError -> Maybe FilePath
1198 ioeGetErrorString     :: IOError -> String
1199 ioeGetHandle          :: IOError -> Maybe Handle
1200
1201 ioeGetHandle (IOException (IOError h _ _ _ _)) = h
1202 ioeGetHandle (UserError _) = Nothing
1203 ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
1204
1205 ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
1206 ioeGetErrorString (UserError str) = str
1207 ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
1208
1209 ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
1210 ioeGetFileName (UserError _) = Nothing
1211 ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
1212
1213 -- ---------------------------------------------------------------------------
1214 -- debugging
1215
1216 #ifdef DEBUG_DUMP
1217 puts :: String -> IO ()
1218 puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
1219                                      return ()
1220 #endif