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