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