ghc/lib/std/PrelHandle.hsc

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