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