-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
-- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.1 2001/12/21 15:07:22 simonmar Exp $
+-- $Id: Handle.hs,v 1.6 2002/03/26 17:06:32 simonmar Exp $
--
-- (c) The University of Glasgow, 1994-2001
--
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off,
+ read_off, read_off_ba,
+ write_off, write_off_ba,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
hClose, hClose_help,
HandlePosn(..), hGetPosn, hSetPosn,
- SeekMode(..), hSeek,
+ SeekMode(..), hSeek, hTell,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
- ioeGetFileName, ioeGetErrorString, ioeGetHandle,
#ifdef DEBUG_DUMP
puts,
import Data.Maybe
import Foreign
import Foreign.C
+import System.IO.Error
import GHC.Posix
import GHC.Real
withHandle fun h@(FileHandle m) act = withHandle' fun h m act
withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
+withHandle' :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle' fun h m act =
block $ do
h_ <- takeMVar m
= 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 ##) }
+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##) ##)
+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##)) ##)
+readCharFromBuffer slab (I# off)
+ = IO $ \s -> case readCharArray# slab off s of
+ (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek (fromIntegral fd) (fromIntegral off) sSEEK_CUR)
+ (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off (fromIntegral fd) is_stream b (fromIntegral r)
- (fromIntegral bytes))
+ (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
+ (fromIntegral bytes))
(threadWaitWrite fd)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
-foreign import "__hscore_PrelHandle_write" unsafe
- write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes))
+ (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
(threadWaitRead fd)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
-foreign import "__hscore_PrelHandle_read" unsafe
- read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-- ---------------------------------------------------------------------------
-- Standard Handles
| otherwise = False
binary_flags
- | binary = PrelHandle.o_BINARY
+ | binary = o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
mkFileHandle fd is_stream filepath ha_type binary
-foreign import "lockFile" unsafe
+foreign import ccall unsafe "lockFile"
lockFile :: CInt -> CInt -> CInt -> IO CInt
-foreign import "unlockFile" unsafe
+foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
-- then closed immediately. We have to be careful with DuplexHandles
-- though: we have to leave the closing to the finalizer in that case,
-- because the write side may still be in use.
+hClose_help :: Handle__ -> IO Handle__
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return handle_
_ -> do
- let fd = fromIntegral (haFD handle_)
+ let fd = haFD handle_
+ c_fd = fromIntegral fd
+
flushWriteBufferOnly handle_
- -- close the file descriptor, but not when this is the read side
- -- of a duplex handle.
+ -- close the file descriptor, but not when this is the read
+ -- side of a duplex handle, and not when this is one of the
+ -- std file handles.
case haOtherSide handle_ of
- Nothing -> throwErrnoIfMinus1Retry_ "hClose"
+ Nothing ->
+ when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+ throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream handle_) fd)
+ (closeFd (haIsStream handle_) c_fd)
#else
- (c_close fd)
+ (c_close c_fd)
#endif
Just _ -> return ()
writeIORef (haBuffers handle_) BufferListNil
-- unlock it
- unlockFile fd
+ unlockFile c_fd
-- we must set the fd to -1, because the finalizer is going
-- to run eventually and try to close/unlock it.
-- position of `hdl' to a previously obtained position `p'.
hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(mingw32_TARGET_OS)
- -- 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 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)
-# 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)
-
+hGetPosn handle = do
+ posn <- hTell handle
+ return (HandlePosn handle posn)
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
writeIORef ref new_buf
do_seek
+
+hTell :: Handle -> IO Integer
+hTell handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(mingw32_TARGET_OS)
+ -- 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 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)
+# 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 real_posn
+
-- -----------------------------------------------------------------------------
-- Handle Properties
-- -----------------------------------------------------------------------------
-- hSetBinaryMode
+hSetBinaryMode :: Handle -> Bool -> IO ()
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
do throwErrnoIfMinus1_ "hSetBinaryMode"
(setmode (fromIntegral (haFD handle_)) bin)
return handle_{haIsBin=bin}
-foreign import "__hscore_setmode" unsafe
+foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
--- -----------------------------------------------------------------------------
--- 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))
+puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
return ()
#endif
-- -----------------------------------------------------------------------------
-- wrappers to platform-specific constants:
-foreign import ccall "__hscore_supportsTextMode" unsafe
+foreign import ccall unsafe "__hscore_supportsTextMode"
tEXT_MODE_SEEK_ALLOWED :: Bool
-foreign import ccall "__hscore_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int
-foreign import ccall "__hscore_seek_cur" unsafe sEEK_CUR :: CInt
-foreign import ccall "__hscore_seek_set" unsafe sEEK_SET :: CInt
-foreign import ccall "__hscore_seek_end" unsafe sEEK_END :: CInt
-foreign import ccall "__hscore_o_binary" unsafe o_BINARY :: CInt
-
-
+foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
projects / ghc-base.git / blobdiff