#undef DEBUG
-- -----------------------------------------------------------------------------
--- $Id: PrelHandle.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
+-- $Id: PrelHandle.hsc,v 1.15 2001/07/13 15:01:28 simonmar Exp $
--
-- (c) The University of Glasgow, 1994-2001
--
-- This module defines the basic operations on I/O "handles".
module PrelHandle (
- withHandle, withHandle_,
+ withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
read_off,
- ioe_closedHandle, ioe_EOF,
+ ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
- hClose, hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
hFlush,
+ hClose, hClose_help,
+
HandlePosn(..), hGetPosn, hSetPosn,
SeekMode(..), hSeek,
-- -----------------------------------------------------------------------------
-- TODO:
--- hWaitForInput blocks (should use a timeout).
+-- hWaitForInput blocks (should use a timeout)
-- unbuffered hGetLine is a bit dodgy
-- when the read buffer is non-empty? (no way to flush the buffer)
-- ---------------------------------------------------------------------------
+-- Are files opened by default in text or binary mode, if the user doesn't
+-- specify?
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
+
+-- Is seeking on text-mode handles allowed, or not?
+tEXT_MODE_SEEK_ALLOWED :: Bool
+#if defined(mingw32_TARGET_OS)
+tEXT_MODE_SEEK_ALLOWED = False
+#else
+tEXT_MODE_SEEK_ALLOWED = True
+#endif
+
+
+-- ---------------------------------------------------------------------------
-- Creating a new handle
newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO 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,
+original 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@(DuplexHandle m _) act = withHandle' fun h m act
withHandle' fun h m act =
block $ do
= case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
- ReadHandle -> ioException not_writeable_error
+ ReadHandle -> ioe_notWritable
ReadWriteHandle -> do
let ref = haBuffer handle_
buf <- readIORef ref
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.
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioException not_readable_error
- WriteHandle -> ioException not_readable_error
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
ReadWriteHandle -> do
let ref = haBuffer handle_
buf <- readIORef ref
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.
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)
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notSeekable
+ _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
+ | otherwise -> ioe_notSeekable_notBin
-- -----------------------------------------------------------------------------
-- Handy IOErrors
-ioe_closedHandle :: IO a
-ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" "" Nothing)
-
-ioe_EOF :: IO a
-ioe_EOF = ioException (IOError Nothing EOF "" "" Nothing)
+ioe_closedHandle, ioe_EOF,
+ ioe_notReadable, ioe_notWritable,
+ ioe_notSeekable, ioe_notSeekable_notBin :: IO a
+
+ioe_closedHandle = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is closed" Nothing)
+ioe_EOF = ioException
+ (IOError Nothing EOF "" "" Nothing)
+ioe_notReadable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing)
+ioe_notWritable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for writing" Nothing)
+ioe_notSeekable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing)
+ioe_notSeekable_notBin = ioException
+ (IOError Nothing IllegalOperation ""
+ "seek operations on text-mode handles are not allowed on this platform"
+ Nothing)
+
+ioe_bufsiz :: Int -> IO a
+ioe_bufsiz n = ioException
+ (IOError Nothing InvalidArgument "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
+ -- 9 => should be parens'ified.
-- -----------------------------------------------------------------------------
-- Handle Finalizers
getBuffer fd state = do
buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
ioref <- newIORef buffer
- is_tty <- c_isatty (fromIntegral fd)
+ is_tty <- fdIsTTY fd
let buffer_mode
- | toBool is_tty = LineBuffering
- | otherwise = BlockBuffering Nothing
+ | is_tty = LineBuffering
+ | otherwise = BlockBuffering Nothing
return (ioref, buffer_mode)
-- 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)
+# ifdef DEBUG_DUMP
+ puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
+# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
(c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR))
return buf{ bufWPtr=0, bufRPtr=0 }
(read_off fd b (fromIntegral w) (fromIntegral bytes))
(threadWaitRead fd)
let res' = fromIntegral res
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
+#endif
if res' == 0
then if w == 0
then ioe_EOF
newFileHandle stdHandleFinalizer
(Handle__ { haFD = fd_stdin,
haType = ReadHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haBufferMode = bmode,
haFilePath = "<stdin>",
haBuffer = buf,
newFileHandle stdHandleFinalizer
(Handle__ { haFD = fd_stdout,
haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haBufferMode = bmode,
haFilePath = "<stdout>",
haBuffer = buf,
newFileHandle stdHandleFinalizer
(Handle__ { haFD = fd_stderr,
haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haBufferMode = NoBuffering,
haFilePath = "<stderr>",
haBuffer = buffer,
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im =
catch
- (openFile' fp (TextMode im))
+ (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
+ then BinaryMode im
+ else TextMode im))
(\e -> throw (addFilePathToIOError "openFile" fp e))
openFileEx :: FilePath -> IOModeEx -> IO Handle
ReadWriteMode -> rw_flags
AppendMode -> append_flags
+ truncate | WriteMode <- mode = True
+ | otherwise = False
+
binary_flags
#ifdef HAVE_O_BINARY
| binary = o_BINARY
throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
- openFd fd filepath mode
+ openFd fd filepath mode binary truncate
+ -- ASSERT: if we just created the file, then openFd won't fail
+ -- (so we don't need to worry about removing the newly created file
+ -- in the event of an error).
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
+write_flags = output_flags .|. o_WRONLY
rw_flags = output_flags .|. o_RDWR
-append_flags = output_flags .|. o_WRONLY .|. o_APPEND
+append_flags = write_flags .|. o_APPEND
-- ---------------------------------------------------------------------------
-- openFd
-openFd :: FD -> FilePath -> IOMode -> IO Handle
-openFd fd filepath mode = do
+openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
+openFd fd filepath mode binary truncate = do
-- turn on non-blocking mode
setNonBlockingFD fd
"is a directory" Nothing)
Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath
- | otherwise -> mkFileHandle fd filepath ha_type
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
+ | otherwise -> mkFileHandle fd filepath ha_type binary
-- regular files need to be locked
RegularFile -> do
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing)
- mkFileHandle fd filepath ha_type
+ -- truncate the file if necessary
+ when truncate (fileTruncate filepath)
-foreign import "lockFile" unsafe
+ mkFileHandle fd filepath ha_type binary
+
+
+foreign import "lockFile" unsafe
lockFile :: CInt -> CInt -> CInt -> IO CInt
-foreign import "unlockFile" unsafe
+foreign import "unlockFile" unsafe
unlockFile :: CInt -> IO CInt
-
-mkFileHandle :: FD -> FilePath -> HandleType -> IO Handle
-mkFileHandle fd filepath ha_type = do
+mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
+mkFileHandle fd filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
spares <- newIORef BufferListNil
newFileHandle handleFinalizer
(Handle__ { haFD = fd,
haType = ha_type,
+ haIsBin = binary,
haBufferMode = bmode,
haFilePath = filepath,
haBuffer = buf,
haBuffers = spares
})
-mkDuplexHandle :: FD -> FilePath -> IO Handle
-mkDuplexHandle fd filepath = do
+mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
+mkDuplexHandle fd filepath binary = do
(w_buf, w_bmode) <- getBuffer fd WriteBuffer
w_spares <- newIORef BufferListNil
let w_handle_ =
Handle__ { haFD = fd,
haType = WriteHandle,
+ haIsBin = binary,
haBufferMode = w_bmode,
haFilePath = filepath,
haBuffer = w_buf,
let r_handle_ =
Handle__ { haFD = fd,
haType = ReadSideHandle write_side,
+ haIsBin = binary,
haBufferMode = r_bmode,
haFilePath = filepath,
haBuffer = r_buf,
haType = ClosedHandle
}
-hClose' h m =
- withHandle__' "hClose" h m $ \ handle_ -> do
+hClose' h m = withHandle__' "hClose" h m $ hClose_help
+
+hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return handle_
_ -> do
-- 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 $
+ when (is_tty && isReadableHandleType (haType handle_)) $
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
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
#if defined(_WIN32)
- -- urgh, on Windows we have to worry about /n -> /r/n translation,
+ -- 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"
let real_posn
| bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
| otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
-
+# ifdef DEBUG_DUMP
+ puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
+ puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
+# endif
return (HandlePosn handle real_posn)
hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset =
wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+# ifdef DEBUG_DUMP
+ puts ("hSeek " ++ show (mode,offset) ++ "\n")
+# endif
let ref = haBuffer handle_
buf <- readIORef ref
let r = bufRPtr buf
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
+ htype -> return (isReadableHandleType htype)
hIsWritable :: Handle -> IO Bool
hIsWritable (DuplexHandle _ _) = return False
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
+ htype -> return (isWritableHandleType htype)
-- Querying how a handle buffers its data:
SemiClosedHandle -> ioe_closedHandle
AppendHandle -> return False
_ -> do t <- fdType (haFD handle_)
- return (t == RegularFile)
+ return (t == RegularFile
+ && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
-- Changing echo status
-- 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
+hSetBinaryMode handle bin =
+ withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
+ do let flg | bin = (#const O_BINARY)
+ | otherwise = (#const O_TEXT)
+ throwErrnoIfMinus1_ "hSetBinaryMode"
+ (setmode (fromIntegral (haFD handle_)) flg)
+ return handle_{haIsBin=bin}
foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
#else
-hSetBinaryMode _ _ = return ()
+hSetBinaryMode handle bin =
+ withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
+ return handle_{haIsBin=bin}
#endif
-- -----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff