--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#undef DEBUG_DUMP
+#undef DEBUG
+
+-- -----------------------------------------------------------------------------
+-- $Id: PrelHandle.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2001
+--
+-- This module defines the basic operations on I/O "handles".
+
+module PrelHandle (
+ withHandle, withHandle_,
+ wantWritableHandle, wantReadableHandle, wantSeekableHandle,
+
+ newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+ read_off,
+
+ ioe_closedHandle, ioe_EOF,
+
+ stdin, stdout, stderr,
+ IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
+ hClose, hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFlush,
+
+ HandlePosn(..), hGetPosn, hSetPosn,
+ SeekMode(..), hSeek,
+
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
+ hSetEcho, hGetEcho, hIsTerminalDevice,
+ ioeGetFileName, ioeGetErrorString, ioeGetHandle,
+
+#ifdef DEBUG_DUMP
+ puts,
+#endif
+
+ ) where
+
+#include "HsStd.h"
+
+import Monad
+
+import PrelBits
+import PrelPosix
+import PrelMarshalUtils
+import PrelCString
+import PrelCTypes
+import PrelCError
+import PrelReal
+
+import PrelArr
+import PrelBase
+import PrelPtr
+import PrelRead ( Read )
+import PrelList
+import PrelIOBase
+import PrelMaybe ( Maybe(..) )
+import PrelException
+import PrelEnum
+import PrelNum ( Integer(..), Num(..) )
+import PrelShow
+import PrelReal ( toInteger )
+
+import PrelConc
+
+-- -----------------------------------------------------------------------------
+-- TODO:
+
+-- hWaitForInput blocks (should use a timeout).
+
+-- unbuffered hGetLine is a bit dodgy
+
+-- hSetBuffering: can't change buffering on a stream,
+-- when the read buffer is non-empty? (no way to flush the buffer)
+
+-- ---------------------------------------------------------------------------
+-- Creating a new handle
+
+newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle finalizer hc = do
+ m <- newMVar hc
+ addMVarFinalizer m (finalizer m)
+ return (FileHandle m)
+
+-- ---------------------------------------------------------------------------
+-- Working with Handles
+
+{-
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+orignal handle is always replaced [ this is the case at the moment,
+but we might want to revisit this in the future --SDM ].
+-}
+
+{-# INLINE withHandle #-}
+withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle fun h@(FileHandle m) act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle r w) act = do
+ withHandle' fun h r act
+ withHandle' fun h w act
+
+withHandle' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ (h',v) <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return v
+
+{-# INLINE withHandle_ #-}
+withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
+withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
+
+withHandle_' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ v <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h_
+ putMVar m h_
+ return v
+
+withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
+withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle r w) act = do
+ withHandle__' fun h r act
+ withHandle__' fun h w act
+
+withHandle__' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ h' <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return ()
+
+augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
+ = IOException (IOError (Just h) iot fun str filepath)
+ where filepath | Just _ <- fp = fp
+ | otherwise = Just (haFilePath h_)
+augmentIOError other_exception _ _ _
+ = other_exception
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for write operations.
+
+wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWritableHandle fun h@(FileHandle m) act
+ = wantWritableHandle' fun h m act
+wantWritableHandle fun h@(DuplexHandle _ m) act
+ = wantWritableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkWritableHandle
+
+wantWritableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantWritableHandle' fun h m act
+ = withHandle_' fun h m (checkWritableHandle act)
+
+checkWritableHandle act handle_
+ = case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ ReadHandle -> ioException not_writeable_error
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ new_buf <-
+ if not (bufferIsWritable buf)
+ then do b <- flushReadBuffer (haFD handle_) buf
+ return b{ bufState=WriteBuffer }
+ else return buf
+ writeIORef ref new_buf
+ act handle_
+ _other -> act handle_
+ where
+ not_writeable_error =
+ IOError Nothing IllegalOperation ""
+ "handle is not open for writing" Nothing
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for read operations.
+
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle fun h@(FileHandle m) act
+ = wantReadableHandle' fun h m act
+wantReadableHandle fun h@(DuplexHandle m _) act
+ = wantReadableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkReadableHandle
+
+wantReadableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantReadableHandle' fun h m act
+ = withHandle_' fun h m (checkReadableHandle act)
+
+checkReadableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ when (bufferIsWritable buf) $ do
+ new_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef ref new_buf{ bufState=ReadBuffer }
+ act handle_
+ _other -> act handle_
+ where
+ not_readable_error =
+ IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for seek operations.
+
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing)
+wantSeekableHandle fun h@(FileHandle m) act =
+ withHandle_' fun h m (checkSeekableHandle act)
+
+checkSeekableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> not_seekable_error
+ _ -> act handle_
+
+not_seekable_error
+ = ioException (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing)
+
+-- -----------------------------------------------------------------------------
+-- Handy IOErrors
+
+ioe_closedHandle :: IO a
+ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" "" Nothing)
+
+ioe_EOF :: IO a
+ioe_EOF = ioException (IOError Nothing EOF "" "" Nothing)
+
+-- -----------------------------------------------------------------------------
+-- Handle Finalizers
+
+-- For a duplex handle, we arrange that the read side points to the write side
+-- (and hence keeps it alive if the read side is alive). This is done by
+-- having the haType field of the read side be ReadSideHandle with a pointer
+-- to the write side. The finalizer is then placed on the write side, and
+-- the handle only gets finalized once, when both sides are no longer
+-- required.
+
+addFinalizer :: Handle -> IO ()
+addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m)
+addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w)
+
+stdHandleFinalizer :: MVar Handle__ -> IO ()
+stdHandleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+
+handleFinalizer :: MVar Handle__ -> IO ()
+handleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+ let fd = fromIntegral (haFD h_)
+ unlockFile fd
+ -- ToDo: closesocket() for a WINSOCK socket?
+ when (fd /= -1) (c_close fd >> return ())
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Grimy buffer operations
+
+#ifdef DEBUG
+checkBufferInvariants h_ = do
+ let ref = haBuffer h_
+ Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
+ if not (
+ size > 0
+ && r <= w
+ && w <= size
+ && ( r /= w || (r == 0 && w == 0) )
+ && ( state /= WriteBuffer || r == 0 )
+ && ( state /= WriteBuffer || w < size ) -- write buffer is never full
+ )
+ then error "buffer invariant violation"
+ else return ()
+#else
+checkBufferInvariants h_ = return ()
+#endif
+
+newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
+newEmptyBuffer b state size
+ = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
+
+allocateBuffer :: Int -> BufferState -> IO Buffer
+allocateBuffer sz@(I## size) state = IO $ \s ->
+ case newByteArray## size s of { (## s, b ##) ->
+ (## s, newEmptyBuffer b state sz ##) }
+
+writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
+writeCharIntoBuffer slab (I## off) (C## c)
+ = IO $ \s -> case writeCharArray## slab off c s of
+ s -> (## s, I## (off +## 1##) ##)
+
+readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
+readCharFromBuffer slab (I## off)
+ = IO $ \s -> case readCharArray## slab off s of
+ (## s, c ##) -> (## s, (C## c, I## (off +## 1##)) ##)
+
+dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int
+
+getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
+getBuffer fd state = do
+ buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
+ ioref <- newIORef buffer
+ is_tty <- c_isatty (fromIntegral fd)
+
+ let buffer_mode
+ | toBool is_tty = LineBuffering
+ | otherwise = BlockBuffering Nothing
+
+ return (ioref, buffer_mode)
+
+mkUnBuffer :: IO (IORef Buffer)
+mkUnBuffer = do
+ buffer <- allocateBuffer 1 ReadBuffer
+ newIORef buffer
+
+-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
+flushWriteBufferOnly :: Handle__ -> IO ()
+flushWriteBufferOnly h_ = do
+ let fd = haFD h_
+ ref = haBuffer h_
+ buf <- readIORef ref
+ new_buf <- if bufferIsWritable buf
+ then flushWriteBuffer fd buf
+ else return buf
+ writeIORef ref new_buf
+
+-- flushBuffer syncs the file with the buffer, including moving the
+-- file pointer backwards in the case of a read buffer.
+flushBuffer :: Handle__ -> IO ()
+flushBuffer h_ = do
+ let ref = haBuffer h_
+ buf <- readIORef ref
+
+ flushed_buf <-
+ case bufState buf of
+ ReadBuffer -> flushReadBuffer (haFD h_) buf
+ WriteBuffer -> flushWriteBuffer (haFD h_) buf
+
+ writeIORef ref flushed_buf
+
+-- When flushing a read buffer, we seek backwards by the number of
+-- characters in the buffer. The file descriptor must therefore be
+-- seekable: attempting to flush the read buffer on an unseekable
+-- handle is not allowed.
+flushReadBuffer :: FD -> Buffer -> IO Buffer
+flushReadBuffer fd buf
+ | bufferEmpty buf = return buf
+ | otherwise = do
+ let off = negate (bufWPtr buf - bufRPtr buf)
+ throwErrnoIfMinus1Retry "flushReadBuffer"
+ (c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR))
+ return buf{ bufWPtr=0, bufRPtr=0 }
+
+flushWriteBuffer :: FD -> Buffer -> IO Buffer
+flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+ let bytes = w - r
+#ifdef DEBUG_DUMP
+ puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
+#endif
+ if bytes == 0
+ then return (buf{ bufRPtr=0, bufWPtr=0 })
+ else do
+ res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
+ (write_off (fromIntegral fd) b (fromIntegral r)
+ (fromIntegral bytes))
+ (threadWaitWrite fd)
+ let res' = fromIntegral res
+ if res' < bytes
+ then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
+ else return buf{ bufRPtr=0, bufWPtr=0 }
+
+foreign import "write_wrap" unsafe
+ write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int write_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return write(fd, ptr + off, size); }
+
+
+fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBuffer fd is_line
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+ fillReadBufferLoop fd is_line buf b w size
+
+-- For a line buffer, we just get the first chunk of data to arrive,
+-- and don't wait for the whole buffer to be full (but we *do* wait
+-- until some data arrives). This isn't really line buffering, but it
+-- appears to be what GHC has done for a long time, and I suspect it
+-- is more useful than line buffering in most cases.
+
+fillReadBufferLoop fd is_line buf b w size = do
+ let bytes = size - w
+ if bytes == 0 -- buffer full?
+ then return buf{ bufRPtr=0, bufWPtr=w }
+ else do
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
+#endif
+ res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
+ (read_off fd b (fromIntegral w) (fromIntegral bytes))
+ (threadWaitRead fd)
+ let res' = fromIntegral res
+ if res' == 0
+ then if w == 0
+ then ioe_EOF
+ else return buf{ bufRPtr=0, bufWPtr=w }
+ else if res' < bytes && not is_line
+ then fillReadBufferLoop fd is_line buf b (w+res') size
+ else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+foreign import "read_wrap" unsafe
+ read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int read_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return read(fd, ptr + off, size); }
+
+-- ---------------------------------------------------------------------------
+-- Standard Handles
+
+-- Three handles are allocated during program initialisation. The first
+-- two manage input or output from the Haskell program's standard input
+-- or output channel respectively. The third manages output to the
+-- standard error channel. These handles are initially open.
+
+fd_stdin = 0 :: FD
+fd_stdout = 1 :: FD
+fd_stderr = 2 :: FD
+
+stdin :: Handle
+stdin = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ setNonBlockingFD fd_stdin
+ (buf, bmode) <- getBuffer fd_stdin ReadBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdin,
+ haType = ReadHandle,
+ haBufferMode = bmode,
+ haFilePath = "<stdin>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stdout :: Handle
+stdout = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stdout
+ (buf, bmode) <- getBuffer fd_stdout WriteBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdout,
+ haType = WriteHandle,
+ haBufferMode = bmode,
+ haFilePath = "<stdout>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stderr :: Handle
+stderr = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stderr
+ buffer <- mkUnBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stderr,
+ haType = WriteHandle,
+ haBufferMode = NoBuffering,
+ haFilePath = "<stderr>",
+ haBuffer = buffer,
+ haBuffers = spares
+ })
+
+-- ---------------------------------------------------------------------------
+-- Opening and Closing Files
+
+{-
+Computation `openFile file mode' allocates and returns a new, open
+handle to manage the file `file'. It manages input if `mode'
+is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
+and both input and output if mode is `ReadWriteMode'.
+
+If the file does not exist and it is opened for output, it should be
+created as a new file. If `mode' is `WriteMode' and the file
+already exists, then it should be truncated to zero length. The
+handle is positioned at the end of the file if `mode' is
+`AppendMode', and otherwise at the beginning (in which case its
+internal position is 0).
+
+Implementations should enforce, locally to the Haskell process,
+multiple-reader single-writer locking on files, which is to say that
+there may either be many handles on the same file which manage input,
+or just one handle on the file which manages output. If any open or
+semi-closed handle is managing a file for output, no new handle can be
+allocated for that file. If any open or semi-closed handle is
+managing a file for input, new handles can only be allocated if they
+do not manage output.
+
+Two files are the same if they have the same absolute name. An
+implementation is free to impose stricter conditions.
+-}
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+data IOModeEx
+ = BinaryMode IOMode
+ | TextMode IOMode
+ deriving (Eq, Read, Show)
+
+addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
+ = IOException (IOError h iot fun str (Just fp))
+addFilePathToIOError _ _ other_exception
+ = other_exception
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp im =
+ catch
+ (openFile' fp (TextMode im))
+ (\e -> throw (addFilePathToIOError "openFile" fp e))
+
+openFileEx :: FilePath -> IOModeEx -> IO Handle
+openFileEx fp m =
+ catch
+ (openFile' fp m)
+ (\e -> throw (addFilePathToIOError "openFileEx" fp e))
+
+
+openFile' filepath ex_mode =
+ withCString filepath $ \ f ->
+
+ let
+ (mode, binary) =
+ case ex_mode of
+ BinaryMode bmo -> (bmo, True)
+ TextMode tmo -> (tmo, False)
+
+ oflags1 = case mode of
+ ReadMode -> read_flags
+ WriteMode -> write_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
+
+ binary_flags
+#ifdef HAVE_O_BINARY
+ | binary = o_BINARY
+#endif
+ | otherwise = 0
+
+ oflags = oflags1 .|. binary_flags
+ in do
+
+ -- the old implementation had a complicated series of three opens,
+ -- which is perhaps because we have to be careful not to open
+ -- directories. However, the man pages I've read say that open()
+ -- always returns EISDIR if the file is a directory and was opened
+ -- for writing, so I think we're ok with a single open() here...
+ fd <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ openFd fd filepath mode
+
+
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+read_flags = std_flags .|. o_RDONLY
+write_flags = output_flags .|. o_WRONLY .|. o_TRUNC
+rw_flags = output_flags .|. o_RDWR
+append_flags = output_flags .|. o_WRONLY .|. o_APPEND
+
+-- ---------------------------------------------------------------------------
+-- openFd
+
+openFd :: FD -> FilePath -> IOMode -> IO Handle
+openFd fd filepath mode = do
+ -- turn on non-blocking mode
+ setNonBlockingFD fd
+
+ let (ha_type, write) =
+ case mode of
+ ReadMode -> ( ReadHandle, False )
+ WriteMode -> ( WriteHandle, True )
+ ReadWriteMode -> ( ReadWriteHandle, True )
+ AppendMode -> ( AppendHandle, True )
+
+ -- open() won't tell us if it was a directory if we only opened for
+ -- reading, so check again.
+ fd_type <- fdType fd
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
+
+ Stream
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath
+ | otherwise -> mkFileHandle fd filepath ha_type
+
+ -- regular files need to be locked
+ RegularFile -> do
+ r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
+ mkFileHandle fd filepath ha_type
+
+
+foreign import "lockFile" unsafe
+ lockFile :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "unlockFile" unsafe
+ unlockFile :: CInt -> IO CInt
+
+
+mkFileHandle :: FD -> FilePath -> HandleType -> IO Handle
+mkFileHandle fd filepath ha_type = do
+ (buf, bmode) <- getBuffer fd (initBufferState ha_type)
+ spares <- newIORef BufferListNil
+ newFileHandle handleFinalizer
+ (Handle__ { haFD = fd,
+ haType = ha_type,
+ haBufferMode = bmode,
+ haFilePath = filepath,
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+mkDuplexHandle :: FD -> FilePath -> IO Handle
+mkDuplexHandle fd filepath = do
+ (w_buf, w_bmode) <- getBuffer fd WriteBuffer
+ w_spares <- newIORef BufferListNil
+ let w_handle_ =
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
+ haBufferMode = w_bmode,
+ haFilePath = filepath,
+ haBuffer = w_buf,
+ haBuffers = w_spares
+ }
+ write_side <- newMVar w_handle_
+
+ (r_buf, r_bmode) <- getBuffer fd ReadBuffer
+ r_spares <- newIORef BufferListNil
+ let r_handle_ =
+ Handle__ { haFD = fd,
+ haType = ReadSideHandle write_side,
+ haBufferMode = r_bmode,
+ haFilePath = filepath,
+ haBuffer = r_buf,
+ haBuffers = r_spares
+ }
+ read_side <- newMVar r_handle_
+
+ addMVarFinalizer write_side (handleFinalizer write_side)
+ return (DuplexHandle read_side write_side)
+
+
+initBufferState ReadHandle = ReadBuffer
+initBufferState _ = WriteBuffer
+
+-- ---------------------------------------------------------------------------
+-- Closing a handle
+
+-- Computation `hClose hdl' makes handle `hdl' closed. Before the
+-- computation finishes, any items buffered for output and not already
+-- sent to the operating system are flushed as for `hFlush'.
+
+-- For a duplex handle, we close&flush the write side, and just close
+-- the read side.
+
+hClose :: Handle -> IO ()
+hClose h@(FileHandle m) = hClose' h m
+hClose h@(DuplexHandle r w) = do
+ hClose' h w
+ withHandle__' "hClose" h r $ \ handle_ -> do
+ return handle_{ haFD = -1,
+ haType = ClosedHandle
+ }
+
+hClose' h m =
+ withHandle__' "hClose" h m $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return handle_
+ _ -> do
+ let fd = fromIntegral (haFD handle_)
+ flushWriteBufferOnly handle_
+ throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
+
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile fd
+
+ -- we must set the fd to -1, because the finalizer is going
+ -- to run eventually and try to close/unlock it.
+ return (handle_{ haFD = -1,
+ haType = ClosedHandle
+ })
+
+-----------------------------------------------------------------------------
+-- Detecting the size of a file
+
+-- For a handle `hdl' which attached to a physical file, `hFileSize
+-- hdl' returns the size of `hdl' in terms of the number of items
+-- which can be read from `hdl'.
+
+hFileSize :: Handle -> IO Integer
+hFileSize handle =
+ withHandle_ "hFileSize" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBufferOnly handle_
+ r <- fdFileSize (haFD handle_)
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing)
+
+-- ---------------------------------------------------------------------------
+-- Detecting the End of Input
+
+-- For a readable handle `hdl', `hIsEOF hdl' returns
+-- `True' if no further input can be taken from `hdl' or for a
+-- physical file, if the current I/O position is equal to the length of
+-- the file. Otherwise, it returns `False'.
+
+hIsEOF :: Handle -> IO Bool
+hIsEOF handle =
+ catch
+ (do hLookAhead handle; return False)
+ (\e -> if isEOFError e then return True else throw e)
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+-- hLookahead returns the next character from the handle without
+-- removing it from the input buffer, blocking until a character is
+-- available.
+
+hLookAhead :: Handle -> IO Char
+hLookAhead handle = do
+ wantReadableHandle "hLookAhead" handle $ \handle_ -> do
+ let ref = haBuffer handle_
+ fd = haFD handle_
+ is_line = haBufferMode handle_ == LineBuffering
+ buf <- readIORef ref
+
+ -- fill up the read buffer if necessary
+ new_buf <- if bufferEmpty buf
+ then fillReadBuffer fd is_line buf
+ else return buf
+
+ writeIORef ref new_buf
+
+ (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
+ return c
+
+-- ---------------------------------------------------------------------------
+-- Buffering Operations
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. See PrelIOBase for definition and
+-- further explanation of what the type represent.
+
+-- Computation `hSetBuffering hdl mode' sets the mode of buffering for
+-- handle hdl on subsequent reads and writes.
+--
+-- * If mode is LineBuffering, line-buffering should be enabled if possible.
+--
+-- * If mode is `BlockBuffering size', then block-buffering
+-- should be enabled if possible. The size of the buffer is n items
+-- if size is `Just n' and is otherwise implementation-dependent.
+--
+-- * If mode is NoBuffering, then buffering is disabled if possible.
+
+-- If the buffer mode is changed from BlockBuffering or
+-- LineBuffering to NoBuffering, then any items in the output
+-- buffer are written to the device, and any items in the input buffer
+-- are discarded. The default buffering mode when a handle is opened
+-- is implementation-dependent and may depend on the object which is
+-- attached to that handle.
+
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hSetBuffering handle mode =
+ withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> do
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ flushBuffer handle_
+
+ let state = initBufferState (haType handle_)
+ new_buf <-
+ case mode of
+ -- we always have a 1-character read buffer for
+ -- unbuffered handles: it's needed to
+ -- support hLookAhead.
+ NoBuffering -> allocateBuffer 1 ReadBuffer
+ LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ | otherwise -> allocateBuffer n state
+ writeIORef (haBuffer handle_) new_buf
+
+ -- for input terminals we need to put the terminal into
+ -- cooked or raw mode depending on the type of buffering.
+ is_tty <- fdIsTTY (haFD handle_)
+ when is_tty $
+ case mode of
+ NoBuffering -> setCooked (haFD handle_) False
+ _ -> setCooked (haFD handle_) True
+
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef (haBuffers handle_) BufferListNil
+
+ return (handle_{ haBufferMode = mode })
+
+ioe_bufsiz n
+ = ioException (IOError Nothing InvalidArgument "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n [])
+ -- 9 => should be parens'ified.
+ Nothing)
+
+-- -----------------------------------------------------------------------------
+-- hFlush
+
+-- The action `hFlush hdl' causes any items buffered for output
+-- in handle `hdl' to be sent immediately to the operating
+-- system.
+
+hFlush :: Handle -> IO ()
+hFlush handle =
+ wantWritableHandle "hFlush" handle $ \ handle_ -> do
+ buf <- readIORef (haBuffer handle_)
+ if bufferIsWritable buf && not (bufferEmpty buf)
+ then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef (haBuffer handle_) flushed_buf
+ else return ()
+
+
+-- -----------------------------------------------------------------------------
+-- Repositioning Handles
+
+data HandlePosn = HandlePosn Handle HandlePosition
+
+instance Eq HandlePosn where
+ (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
+
+ -- HandlePosition is the Haskell equivalent of POSIX' off_t.
+ -- We represent it as an Integer on the Haskell side, but
+ -- cheat slightly in that hGetPosn calls upon a C helper
+ -- that reports the position back via (merely) an Int.
+type HandlePosition = Integer
+
+-- Computation `hGetPosn hdl' returns the current I/O position of
+-- `hdl' as an abstract position. Computation `hSetPosn p' sets the
+-- position of `hdl' to a previously obtained position `p'.
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(_WIN32)
+ -- urgh, on Windows we have to worry about /n -> /r/n translation,
+ -- so we can't easily calculate the file position using the
+ -- current buffer size. Just flush instead.
+ flushBuffer handle_
+#endif
+
+ let fd = fromIntegral (haFD handle_)
+ posn <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "hGetPosn"
+ (c_lseek fd 0 (#const SEEK_CUR))
+
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ let real_posn
+ | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
+ | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
+
+ return (HandlePosn handle real_posn)
+
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
+
+-- ---------------------------------------------------------------------------
+-- hSeek
+
+{-
+The action `hSeek hdl mode i' sets the position of handle
+`hdl' depending on `mode'. If `mode' is
+
+ * AbsoluteSeek - The position of `hdl' is set to `i'.
+ * RelativeSeek - The position of `hdl' is set to offset `i' from
+ the current position.
+ * SeekFromEnd - The position of `hdl' is set to offset `i' from
+ the end of the file.
+
+Some handles may not be seekable (see `hIsSeekable'), or only
+support a subset of the possible positioning operations (e.g. it may
+only be possible to seek to the end of a tape, or to a positive
+offset from the beginning or current position).
+
+It is not possible to set a negative I/O position, or for a physical
+file, an I/O position beyond the current end-of-file.
+
+Note:
+ - when seeking using `SeekFromEnd', positive offsets (>=0) means
+ seeking at or past EOF.
+
+ - we possibly deviate from the report on the issue of seeking within
+ the buffer and whether to flush it or not. The report isn't exactly
+ clear here.
+-}
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ let r = bufRPtr buf
+ w = bufWPtr buf
+ fd = haFD handle_
+
+ let do_seek =
+ throwErrnoIfMinus1Retry_ "hSeek"
+ (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+
+ whence :: CInt
+ whence = case mode of
+ AbsoluteSeek -> (#const SEEK_SET)
+ RelativeSeek -> (#const SEEK_CUR)
+ SeekFromEnd -> (#const SEEK_END)
+
+ if bufferIsWritable buf
+ then do new_buf <- flushWriteBuffer fd buf
+ writeIORef ref new_buf
+ do_seek
+ else do
+
+ if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
+ then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
+ else do
+
+ new_buf <- flushReadBuffer (haFD handle_) buf
+ writeIORef ref new_buf
+ do_seek
+
+-- -----------------------------------------------------------------------------
+-- Handle Properties
+
+-- A number of operations return information about the properties of a
+-- handle. Each of these operations returns `True' if the handle has
+-- the specified property, and `False' otherwise.
+
+hIsOpen :: Handle -> IO Bool
+hIsOpen handle =
+ withHandle_ "hIsOpen" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
+
+hIsClosed :: Handle -> IO Bool
+hIsClosed handle =
+ withHandle_ "hIsClosed" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return True
+ _ -> return False
+
+{- not defined, nor exported, but mentioned
+ here for documentation purposes:
+
+ hSemiClosed :: Handle -> IO Bool
+ hSemiClosed h = do
+ ho <- hIsOpen h
+ hc <- hIsClosed h
+ return (not (ho || hc))
+-}
+
+hIsReadable :: Handle -> IO Bool
+hIsReadable (DuplexHandle _ _) = return True
+hIsReadable handle =
+ withHandle_ "hIsReadable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isReadable htype)
+ where
+ isReadable ReadHandle = True
+ isReadable (ReadSideHandle _) = True
+ isReadable ReadWriteHandle = True
+ isReadable _ = False
+
+hIsWritable :: Handle -> IO Bool
+hIsWritable (DuplexHandle _ _) = return False
+hIsWritable handle =
+ withHandle_ "hIsWritable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritable htype)
+ where
+ isWritable AppendHandle = True
+ isWritable WriteHandle = True
+ isWritable ReadWriteHandle = True
+ isWritable _ = False
+
+-- Querying how a handle buffers its data:
+
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering handle =
+ withHandle_ "hGetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ ->
+ -- We're being non-standard here, and allow the buffering
+ -- of a semi-closed handle to be queried. -- sof 6/98
+ return (haBufferMode handle_) -- could be stricter..
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable handle =
+ withHandle_ "hIsSeekable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> return False
+ _ -> do t <- fdType (haFD handle_)
+ return (t == RegularFile)
+
+-- -----------------------------------------------------------------------------
+-- Changing echo status
+
+-- Non-standard GHC extension is to allow the echoing status
+-- of a handles connected to terminals to be reconfigured:
+
+hSetEcho :: Handle -> Bool -> IO ()
+hSetEcho handle on = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return ()
+ else
+ withHandle_ "hSetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> setEcho (haFD handle_) on
+
+hGetEcho :: Handle -> IO Bool
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return False
+ else
+ withHandle_ "hGetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> getEcho (haFD handle_)
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> fdIsTTY (haFD handle_)
+
+-- -----------------------------------------------------------------------------
+-- hSetBinaryMode
+
+#ifdef _WIN32
+hSetBinaryMode handle bin =
+ withHandle "hSetBinaryMode" handle $ \ handle_ ->
+ let flg | bin = (#const O_BINARY)
+ | otherwise = (#const O_TEXT)
+ throwErrnoIfMinus1_ "hSetBinaryMode" $
+ setmode (fromIntegral (haFD handle_)) flg
+
+foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
+#else
+hSetBinaryMode _ _ = return ()
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous
+
+-- These three functions are meant to get things out of an IOError.
+
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
+ioeGetHandle :: IOError -> Maybe Handle
+
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+
+-- ---------------------------------------------------------------------------
+-- debugging
+
+#ifdef DEBUG_DUMP
+puts :: String -> IO ()
+puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
+ return ()
+#endif
projects / ghc-hetmet.git / blobdiff