GHC/Handle.hs

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