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