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.1 2001/05/18 16:54:05 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_,
  15   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
  16
  17   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  18   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
  19   read_off,
  20
  21   ioe_closedHandle, ioe_EOF,
  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           -> ioException not_writeable_error
 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   where
 200    not_writeable_error =
 201         IOError Nothing IllegalOperation ""
 202                 "handle is not open for writing" Nothing
 203
 204 -- ---------------------------------------------------------------------------
 205 -- Wrapper for read operations.
 206
 207 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 208 wantReadableHandle fun h@(FileHandle   m)   act
 209   = wantReadableHandle' fun h m act
 210 wantReadableHandle fun h@(DuplexHandle m _) act
 211   = wantReadableHandle' fun h m act
 212   -- ToDo: in the Duplex case, we don't need to checkReadableHandle
 213
 214 wantReadableHandle'
 215         :: String -> Handle -> MVar Handle__
 216         -> (Handle__ -> IO a) -> IO a
 217 wantReadableHandle' fun h m act
 218   = withHandle_' fun h m (checkReadableHandle act)
 219
 220 checkReadableHandle act handle_ =
 221     case haType handle_ of
 222       ClosedHandle         -> ioe_closedHandle
 223       SemiClosedHandle     -> ioe_closedHandle
 224       AppendHandle         -> ioException not_readable_error
 225       WriteHandle          -> ioException not_readable_error
 226       ReadWriteHandle      -> do
 227         let ref = haBuffer handle_
 228         buf <- readIORef ref
 229         when (bufferIsWritable buf) $ do
 230            new_buf <- flushWriteBuffer (haFD handle_) buf
 231            writeIORef ref new_buf{ bufState=ReadBuffer }
 232         act handle_
 233       _other               -> act handle_
 234   where
 235    not_readable_error =
 236         IOError Nothing IllegalOperation ""
 237                 "handle is not open for reading" Nothing
 238
 239 -- ---------------------------------------------------------------------------
 240 -- Wrapper for seek operations.
 241
 242 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 243 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
 244   ioException (IOError (Just h) IllegalOperation fun
 245                    "handle is not seekable" Nothing)
 246 wantSeekableHandle fun h@(FileHandle m) act =
 247   withHandle_' fun h m (checkSeekableHandle act)
 248
 249 checkSeekableHandle act handle_ =
 250     case haType handle_ of
 251       ClosedHandle         -> ioe_closedHandle
 252       SemiClosedHandle     -> ioe_closedHandle
 253       AppendHandle         -> not_seekable_error
 254       _                    -> act handle_
 255
 256 not_seekable_error
 257   = ioException (IOError Nothing IllegalOperation ""
 258                    "handle is not seekable" Nothing)
 259
 260 -- -----------------------------------------------------------------------------
 261 -- Handy IOErrors
 262
 263 ioe_closedHandle :: IO a
 264 ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" "" Nothing)
 265
 266 ioe_EOF :: IO a
 267 ioe_EOF = ioException (IOError Nothing EOF "" "" 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
 661 mkFileHandle :: FD -> FilePath -> HandleType -> IO Handle
 662 mkFileHandle fd filepath ha_type = do
 663   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
 664   spares <- newIORef BufferListNil
 665   newFileHandle handleFinalizer
 666             (Handle__ { haFD = fd,
 667                         haType = ha_type,
 668                         haBufferMode = bmode,
 669                         haFilePath = filepath,
 670                         haBuffer = buf,
 671                         haBuffers = spares
 672                       })
 673
 674 mkDuplexHandle :: FD -> FilePath -> IO Handle
 675 mkDuplexHandle fd filepath = do
 676   (w_buf, w_bmode) <- getBuffer fd WriteBuffer
 677   w_spares <- newIORef BufferListNil
 678   let w_handle_ =
 679              Handle__ { haFD = fd,
 680                         haType = WriteHandle,
 681                         haBufferMode = w_bmode,
 682                         haFilePath = filepath,
 683                         haBuffer = w_buf,
 684                         haBuffers = w_spares
 685                       }
 686   write_side <- newMVar w_handle_
 687
 688   (r_buf, r_bmode) <- getBuffer fd ReadBuffer
 689   r_spares <- newIORef BufferListNil
 690   let r_handle_ =
 691              Handle__ { haFD = fd,
 692                         haType = ReadSideHandle write_side,
 693                         haBufferMode = r_bmode,
 694                         haFilePath = filepath,
 695                         haBuffer = r_buf,
 696                         haBuffers = r_spares
 697                       }
 698   read_side <- newMVar r_handle_
 699
 700   addMVarFinalizer write_side (handleFinalizer write_side)
 701   return (DuplexHandle read_side write_side)
 702
 703
 704 initBufferState ReadHandle = ReadBuffer
 705 initBufferState _          = WriteBuffer
 706
 707 -- ---------------------------------------------------------------------------
 708 -- Closing a handle
 709
 710 -- Computation `hClose hdl' makes handle `hdl' closed.  Before the
 711 -- computation finishes, any items buffered for output and not already
 712 -- sent to the operating system are flushed as for `hFlush'.
 713
 714 -- For a duplex handle, we close&flush the write side, and just close
 715 -- the read side.
 716
 717 hClose :: Handle -> IO ()
 718 hClose h@(FileHandle m)     = hClose' h m
 719 hClose h@(DuplexHandle r w) = do
 720   hClose' h w
 721   withHandle__' "hClose" h r $ \ handle_ -> do
 722   return handle_{ haFD   = -1,
 723                   haType = ClosedHandle
 724                  }
 725
 726 hClose' h m =
 727   withHandle__' "hClose" h m $ \ handle_ -> do
 728   case haType handle_ of
 729       ClosedHandle -> return handle_
 730       _ -> do
 731           let fd = fromIntegral (haFD handle_)
 732           flushWriteBufferOnly handle_
 733           throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
 734
 735           -- free the spare buffers
 736           writeIORef (haBuffers handle_) BufferListNil
 737
 738           -- unlock it
 739           unlockFile fd
 740
 741           -- we must set the fd to -1, because the finalizer is going
 742           -- to run eventually and try to close/unlock it.
 743           return (handle_{ haFD        = -1,
 744                            haType      = ClosedHandle
 745                          })
 746
 747 -----------------------------------------------------------------------------
 748 -- Detecting the size of a file
 749
 750 -- For a handle `hdl' which attached to a physical file, `hFileSize
 751 -- hdl' returns the size of `hdl' in terms of the number of items
 752 -- which can be read from `hdl'.
 753
 754 hFileSize :: Handle -> IO Integer
 755 hFileSize handle =
 756     withHandle_ "hFileSize" handle $ \ handle_ -> do
 757     case haType handle_ of
 758       ClosedHandle              -> ioe_closedHandle
 759       SemiClosedHandle          -> ioe_closedHandle
 760       _ -> do flushWriteBufferOnly handle_
 761               r <- fdFileSize (haFD handle_)
 762               if r /= -1
 763                  then return r
 764                  else ioException (IOError Nothing InappropriateType "hFileSize"
 765                                    "not a regular file" Nothing)
 766
 767 -- ---------------------------------------------------------------------------
 768 -- Detecting the End of Input
 769
 770 -- For a readable handle `hdl', `hIsEOF hdl' returns
 771 -- `True' if no further input can be taken from `hdl' or for a
 772 -- physical file, if the current I/O position is equal to the length of
 773 -- the file.  Otherwise, it returns `False'.
 774
 775 hIsEOF :: Handle -> IO Bool
 776 hIsEOF handle =
 777   catch
 778      (do hLookAhead handle; return False)
 779      (\e -> if isEOFError e then return True else throw e)
 780
 781 isEOF :: IO Bool
 782 isEOF = hIsEOF stdin
 783
 784 -- ---------------------------------------------------------------------------
 785 -- Looking ahead
 786
 787 -- hLookahead returns the next character from the handle without
 788 -- removing it from the input buffer, blocking until a character is
 789 -- available.
 790
 791 hLookAhead :: Handle -> IO Char
 792 hLookAhead handle = do
 793   wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
 794   let ref     = haBuffer handle_
 795       fd      = haFD handle_
 796       is_line = haBufferMode handle_ == LineBuffering
 797   buf <- readIORef ref
 798
 799   -- fill up the read buffer if necessary
 800   new_buf <- if bufferEmpty buf
 801                 then fillReadBuffer fd is_line buf
 802                 else return buf
 803
 804   writeIORef ref new_buf
 805
 806   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
 807   return c
 808
 809 -- ---------------------------------------------------------------------------
 810 -- Buffering Operations
 811
 812 -- Three kinds of buffering are supported: line-buffering,
 813 -- block-buffering or no-buffering.  See PrelIOBase for definition and
 814 -- further explanation of what the type represent.
 815
 816 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
 817 -- handle hdl on subsequent reads and writes.
 818 --
 819 --   * If mode is LineBuffering, line-buffering should be enabled if possible.
 820 --
 821 --   * If mode is `BlockBuffering size', then block-buffering
 822 --     should be enabled if possible.  The size of the buffer is n items
 823 --     if size is `Just n' and is otherwise implementation-dependent.
 824 --
 825 --   * If mode is NoBuffering, then buffering is disabled if possible.
 826
 827 -- If the buffer mode is changed from BlockBuffering or
 828 -- LineBuffering to NoBuffering, then any items in the output
 829 -- buffer are written to the device, and any items in the input buffer
 830 -- are discarded.  The default buffering mode when a handle is opened
 831 -- is implementation-dependent and may depend on the object which is
 832 -- attached to that handle.
 833
 834 hSetBuffering :: Handle -> BufferMode -> IO ()
 835 hSetBuffering handle mode =
 836   withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
 837   case haType handle_ of
 838     ClosedHandle -> ioe_closedHandle
 839     _ -> do
 840          {- Note:
 841             - we flush the old buffer regardless of whether
 842               the new buffer could fit the contents of the old buffer
 843               or not.
 844             - allow a handle's buffering to change even if IO has
 845               occurred (ANSI C spec. does not allow this, nor did
 846               the previous implementation of IO.hSetBuffering).
 847             - a non-standard extension is to allow the buffering
 848               of semi-closed handles to change [sof 6/98]
 849           -}
 850           flushBuffer handle_
 851
 852           let state = initBufferState (haType handle_)
 853           new_buf <-
 854             case mode of
 855                 -- we always have a 1-character read buffer for
 856                 -- unbuffered  handles: it's needed to
 857                 -- support hLookAhead.
 858               NoBuffering            -> allocateBuffer 1 ReadBuffer
 859               LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state
 860               BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
 861               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 862                                       | otherwise -> allocateBuffer n state
 863           writeIORef (haBuffer handle_) new_buf
 864
 865           -- for input terminals we need to put the terminal into
 866           -- cooked or raw mode depending on the type of buffering.
 867           is_tty <- fdIsTTY (haFD handle_)
 868           when is_tty $
 869                 case mode of
 870                   NoBuffering -> setCooked (haFD handle_) False
 871                   _           -> setCooked (haFD handle_) True
 872
 873           -- throw away spare buffers, they might be the wrong size
 874           writeIORef (haBuffers handle_) BufferListNil
 875
 876           return (handle_{ haBufferMode = mode })
 877
 878 ioe_bufsiz n
 879   = ioException (IOError Nothing InvalidArgument "hSetBuffering"
 880                         ("illegal buffer size " ++ showsPrec 9 n [])
 881                                 -- 9 => should be parens'ified.
 882                         Nothing)
 883
 884 -- -----------------------------------------------------------------------------
 885 -- hFlush
 886
 887 -- The action `hFlush hdl' causes any items buffered for output
 888 -- in handle `hdl' to be sent immediately to the operating
 889 -- system.
 890
 891 hFlush :: Handle -> IO ()
 892 hFlush handle =
 893    wantWritableHandle "hFlush" handle $ \ handle_ -> do
 894    buf <- readIORef (haBuffer handle_)
 895    if bufferIsWritable buf && not (bufferEmpty buf)
 896         then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
 897                 writeIORef (haBuffer handle_) flushed_buf
 898         else return ()
 899
 900
 901 -- -----------------------------------------------------------------------------
 902 -- Repositioning Handles
 903
 904 data HandlePosn = HandlePosn Handle HandlePosition
 905
 906 instance Eq HandlePosn where
 907     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 908
 909   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 910   -- We represent it as an Integer on the Haskell side, but
 911   -- cheat slightly in that hGetPosn calls upon a C helper
 912   -- that reports the position back via (merely) an Int.
 913 type HandlePosition = Integer
 914
 915 -- Computation `hGetPosn hdl' returns the current I/O position of
 916 -- `hdl' as an abstract position.  Computation `hSetPosn p' sets the
 917 -- position of `hdl' to a previously obtained position `p'.
 918
 919 hGetPosn :: Handle -> IO HandlePosn
 920 hGetPosn handle =
 921     wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
 922
 923 #if defined(_WIN32)
 924         -- urgh, on Windows we have to worry about /n -> /r/n translation,
 925         -- so we can't easily calculate the file position using the
 926         -- current buffer size.  Just flush instead.
 927       flushBuffer handle_
 928 #endif
 929
 930       let fd = fromIntegral (haFD handle_)
 931       posn <- fromIntegral `liftM`
 932                 throwErrnoIfMinus1Retry "hGetPosn"
 933                    (c_lseek fd 0 (#const SEEK_CUR))
 934
 935       let ref = haBuffer handle_
 936       buf <- readIORef ref
 937
 938       let real_posn
 939            | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
 940            | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
 941
 942       return (HandlePosn handle real_posn)
 943
 944
 945 hSetPosn :: HandlePosn -> IO ()
 946 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 947
 948 -- ---------------------------------------------------------------------------
 949 -- hSeek
 950
 951 {-
 952 The action `hSeek hdl mode i' sets the position of handle
 953 `hdl' depending on `mode'.  If `mode' is
 954
 955  * AbsoluteSeek - The position of `hdl' is set to `i'.
 956  * RelativeSeek - The position of `hdl' is set to offset `i' from
 957                   the current position.
 958  * SeekFromEnd  - The position of `hdl' is set to offset `i' from
 959                   the end of the file.
 960
 961 Some handles may not be seekable (see `hIsSeekable'), or only
 962 support a subset of the possible positioning operations (e.g. it may
 963 only be possible to seek to the end of a tape, or to a positive
 964 offset from the beginning or current position).
 965
 966 It is not possible to set a negative I/O position, or for a physical
 967 file, an I/O position beyond the current end-of-file.
 968
 969 Note:
 970  - when seeking using `SeekFromEnd', positive offsets (>=0) means
 971    seeking at or past EOF.
 972
 973  - we possibly deviate from the report on the issue of seeking within
 974    the buffer and whether to flush it or not.  The report isn't exactly
 975    clear here.
 976 -}
 977
 978 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 979                     deriving (Eq, Ord, Ix, Enum, Read, Show)
 980
 981 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 982 hSeek handle mode offset =
 983     wantSeekableHandle "hSeek" handle $ \ handle_ -> do
 984     let ref = haBuffer handle_
 985     buf <- readIORef ref
 986     let r = bufRPtr buf
 987         w = bufWPtr buf
 988         fd = haFD handle_
 989
 990     let do_seek =
 991           throwErrnoIfMinus1Retry_ "hSeek"
 992             (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
 993
 994         whence :: CInt
 995         whence = case mode of
 996                    AbsoluteSeek -> (#const SEEK_SET)
 997                    RelativeSeek -> (#const SEEK_CUR)
 998                    SeekFromEnd  -> (#const SEEK_END)
 999
1000     if bufferIsWritable buf
1001         then do new_buf <- flushWriteBuffer fd buf
1002                 writeIORef ref new_buf
1003                 do_seek
1004         else do
1005
1006     if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1007         then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1008         else do
1009
1010     new_buf <- flushReadBuffer (haFD handle_) buf
1011     writeIORef ref new_buf
1012     do_seek
1013
1014 -- -----------------------------------------------------------------------------
1015 -- Handle Properties
1016
1017 -- A number of operations return information about the properties of a
1018 -- handle.  Each of these operations returns `True' if the handle has
1019 -- the specified property, and `False' otherwise.
1020
1021 hIsOpen :: Handle -> IO Bool
1022 hIsOpen handle =
1023     withHandle_ "hIsOpen" handle $ \ handle_ -> do
1024     case haType handle_ of
1025       ClosedHandle         -> return False
1026       SemiClosedHandle     -> return False
1027       _                    -> return True
1028
1029 hIsClosed :: Handle -> IO Bool
1030 hIsClosed handle =
1031     withHandle_ "hIsClosed" handle $ \ handle_ -> do
1032     case haType handle_ of
1033       ClosedHandle         -> return True
1034       _                    -> return False
1035
1036 {- not defined, nor exported, but mentioned
1037    here for documentation purposes:
1038
1039     hSemiClosed :: Handle -> IO Bool
1040     hSemiClosed h = do
1041        ho <- hIsOpen h
1042        hc <- hIsClosed h
1043        return (not (ho || hc))
1044 -}
1045
1046 hIsReadable :: Handle -> IO Bool
1047 hIsReadable (DuplexHandle _ _) = return True
1048 hIsReadable handle =
1049     withHandle_ "hIsReadable" handle $ \ handle_ -> do
1050     case haType handle_ of
1051       ClosedHandle         -> ioe_closedHandle
1052       SemiClosedHandle     -> ioe_closedHandle
1053       htype                -> return (isReadable htype)
1054   where
1055     isReadable ReadHandle         = True
1056     isReadable (ReadSideHandle _) = True
1057     isReadable ReadWriteHandle    = True
1058     isReadable _                  = False
1059
1060 hIsWritable :: Handle -> IO Bool
1061 hIsWritable (DuplexHandle _ _) = return False
1062 hIsWritable handle =
1063     withHandle_ "hIsWritable" handle $ \ handle_ -> do
1064     case haType handle_ of
1065       ClosedHandle         -> ioe_closedHandle
1066       SemiClosedHandle     -> ioe_closedHandle
1067       htype                -> return (isWritable htype)
1068   where
1069     isWritable AppendHandle    = True
1070     isWritable WriteHandle     = True
1071     isWritable ReadWriteHandle = True
1072     isWritable _               = False
1073
1074 -- Querying how a handle buffers its data:
1075
1076 hGetBuffering :: Handle -> IO BufferMode
1077 hGetBuffering handle =
1078     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1079     case haType handle_ of
1080       ClosedHandle         -> ioe_closedHandle
1081       _ ->
1082            -- We're being non-standard here, and allow the buffering
1083            -- of a semi-closed handle to be queried.   -- sof 6/98
1084           return (haBufferMode handle_)  -- could be stricter..
1085
1086 hIsSeekable :: Handle -> IO Bool
1087 hIsSeekable handle =
1088     withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1089     case haType handle_ of
1090       ClosedHandle         -> ioe_closedHandle
1091       SemiClosedHandle     -> ioe_closedHandle
1092       AppendHandle         -> return False
1093       _                    -> do t <- fdType (haFD handle_)
1094                                  return (t == RegularFile)
1095
1096 -- -----------------------------------------------------------------------------
1097 -- Changing echo status
1098
1099 -- Non-standard GHC extension is to allow the echoing status
1100 -- of a handles connected to terminals to be reconfigured:
1101
1102 hSetEcho :: Handle -> Bool -> IO ()
1103 hSetEcho handle on = do
1104     isT   <- hIsTerminalDevice handle
1105     if not isT
1106      then return ()
1107      else
1108       withHandle_ "hSetEcho" handle $ \ handle_ -> do
1109       case haType handle_ of
1110          ClosedHandle -> ioe_closedHandle
1111          _            -> setEcho (haFD handle_) on
1112
1113 hGetEcho :: Handle -> IO Bool
1114 hGetEcho handle = do
1115     isT   <- hIsTerminalDevice handle
1116     if not isT
1117      then return False
1118      else
1119        withHandle_ "hGetEcho" handle $ \ handle_ -> do
1120        case haType handle_ of
1121          ClosedHandle -> ioe_closedHandle
1122          _            -> getEcho (haFD handle_)
1123
1124 hIsTerminalDevice :: Handle -> IO Bool
1125 hIsTerminalDevice handle = do
1126     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1127      case haType handle_ of
1128        ClosedHandle -> ioe_closedHandle
1129        _            -> fdIsTTY (haFD handle_)
1130
1131 -- -----------------------------------------------------------------------------
1132 -- hSetBinaryMode
1133
1134 #ifdef _WIN32
1135 hSetBinaryMode handle bin =
1136   withHandle "hSetBinaryMode" handle $ \ handle_ ->
1137     let flg | bin       = (#const O_BINARY)
1138             | otherwise = (#const O_TEXT)
1139     throwErrnoIfMinus1_ "hSetBinaryMode" $
1140         setmode (fromIntegral (haFD handle_)) flg
1141
1142 foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
1143 #else
1144 hSetBinaryMode _ _ = return ()
1145 #endif
1146
1147 -- -----------------------------------------------------------------------------
1148 -- Miscellaneous
1149
1150 -- These three functions are meant to get things out of an IOError.
1151
1152 ioeGetFileName        :: IOError -> Maybe FilePath
1153 ioeGetErrorString     :: IOError -> String
1154 ioeGetHandle          :: IOError -> Maybe Handle
1155
1156 ioeGetHandle (IOException (IOError h _ _ _ _)) = h
1157 ioeGetHandle (UserError _) = Nothing
1158 ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
1159
1160 ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
1161 ioeGetErrorString (UserError str) = str
1162 ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
1163
1164 ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
1165 ioeGetFileName (UserError _) = Nothing
1166 ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
1167
1168 -- ---------------------------------------------------------------------------
1169 -- debugging
1170
1171 #ifdef DEBUG_DUMP
1172 puts :: String -> IO ()
1173 puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
1174                                      return ()
1175 #endif