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