) where
import GlaExts
-import ST
import PrelIOBase
-import PrelHandle (filePtr, readHandle, writeHandle, newHandle)
+import PrelHandle (newHandle, getBMode__, getHandleFd,
+ freeFileObject, freeStdFileObject )
import IO
-import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST )
import Addr
import Foreign
+import Weak ( addForeignFinalizer )
+import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
import PosixUtil
import PosixFiles ( stdInput, stdOutput, stdError )
createPipe = do
bytes <- allocChars ``(2*sizeof(int))''
rc <- _casm_ ``%r = pipe((int *)%0);'' bytes
- if rc /= -1
+ if rc /= ((-1)::Int)
then do
rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
handleToFd :: Handle -> IO Fd
handleToFd h = do
- h_ <- readHandle h
- case h_ of
- ErrorHandle ioError -> writeHandle h h_ >> fail ioError
- ClosedHandle -> writeHandle h h_ >>
- fail (IOError Nothing IllegalOperation
- "handle is closed")
- SemiClosedHandle _ _ -> writeHandle h h_ >>
- fail (IOError Nothing IllegalOperation
- "handle is semi-closed")
- other ->
- let file = filePtr h_ in
- _casm_ `` %r=fileno((FILE *)%0); '' file >>= \ fd@(FD# fd#) ->
- writeHandle h h_ >>
- if fd# /=# (negateInt# 1#) then
- return fd
- else
- syserr "handleToFd"
+ fd <- getHandleFd h
+ let (I# fd#) = fd
+ return (FD# fd#)
-- default is no buffering.
fdToHandle :: Fd -> IO Handle
-fdToHandle fd@(FD# fd#) =
- _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ flags@(I# flags#) ->
- if flags /= -1 then
+fdToHandle fd@(FD# fd#) = do
+ -- first find out what kind of file desc. this is..
+ flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
+ if flags /= ((-1)::Int)
+ then do
let
+ (I# flags#) = flags
+
wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
`neWord#` int2Word# 0#
aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
`neWord#` int2Word# 0#
rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
`neWord#` int2Word# 0#
- (ft,handle_t) =
- if wH then
- if aH
- then ("a",AppendHandle)
- else ("w",WriteHandle)
- else if rwH then
- ("r+",ReadWriteHandle)
- else
- ("r",ReadHandle)
- in
- _ccall_ openFd fd ft >>= \ file_struct@(A# ptr#) ->
- if file_struct /= (``NULL''::Addr) then
+
+ (handle_t, flush_on_close)
+ | wH && aH = (AppendHandle, 1)
+ | wH = (WriteHandle, 1)
+ | rwH = (ReadWriteHandle, 1)
+ | otherwise = (ReadHandle, 0)
+
+ fo <- _ccall_ openFd fd flags (flush_on_close::Int)
+ if fo /= nullAddr then do
{-
A distinction is made here between std{Input,Output,Error} Fds
and all others. The standard descriptors have a finaliser
(or as a result of) program termination.
-}
#ifndef __PARALLEL_HASKELL__
- (if fd == stdInput || fd == stdOutput || fd == stdError then
- makeForeignObj file_struct (``&freeStdFile''::Addr)
+ fo <- mkForeignObj fo
+ if fd == stdInput || fd == stdOutput || fd == stdError then
+ addForeignFinalizer fo (freeStdFileObject fo)
else
- makeForeignObj file_struct (``&freeFile''::Addr)) >>= \ fp ->
- newHandle (handle_t fp Nothing False)
-#else
- newHandle (handle_t file_struct Nothing False)
+ addForeignFinalizer fo (freeFileObject fo)
#endif
- else
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ newHandle (Handle__ fo handle_t bm fd_str)
+ else
syserr "fdToHandle"
- else
- syserr "fdToHandle"
+ else
+ syserr "fdToHandle"
+ where
+ fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
-fdRead fd 0 = return ("", 0)
-fdRead fd nbytes = do
+fdRead _fd 0 = return ("", 0)
+fdRead fd nbytes = do
bytes <- allocChars nbytes
rc <- _ccall_ read fd bytes nbytes
case rc of
-1 -> syserr "fdRead"
- 0 -> fail (IOError Nothing EOF "EOF")
+ 0 -> ioError (IOError Nothing EOF "fdRead" "EOF")
n | n == nbytes -> do
buf <- freeze bytes
- return (unpackPS (unsafeByteArrayToPS buf n), n)
+ s <- unpackNBytesBAIO buf n
+ return (s, n)
| otherwise -> do
-- Let go of the excessively long ByteArray# by copying to a
-- shorter one. Maybe we need a new primitive, shrinkCharArray#?
_casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
} while(0);'' bytes' bytes n
buf <- freeze bytes'
- return (unpackPS (unsafeByteArrayToPS buf n), n)
+ s <- unpackNBytesBAIO buf n
+ return (s, n)
fdWrite :: Fd -> String -> IO ByteCount
fdWrite fd str = do
- buf <- stToIO (psToByteArrayST str)
+ buf <- packStringIO str
rc <- _ccall_ write fd buf (length str)
- if rc /= -1
+ if rc /= ((-1)::Int)
then return rc
else syserr "fdWrite"
queryFdOption :: Fd -> FdOption -> IO Bool
queryFdOption fd CloseOnExec =
- _ccall_ fcntl fd (``F_GETFD''::Int) 0 >>= \ (I# flags#) ->
+ _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int) >>= \ (I# flags#) ->
if flags# /=# -1# then
return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
else
where
fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
queryFdOption fd other =
- _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ (I# flags#) ->
+ _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int) >>= \ (I# flags#) ->
if flags# >=# 0# then
return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
else
setFdOption :: Fd -> FdOption -> Bool -> IO ()
setFdOption fd CloseOnExec val = do
- flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
- if flags /= -1 then do
+ flags <- _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int)
+ if flags /= ((-1)::Int) then do
rc <- (if val then
_casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
else do
_casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
- if rc /= -1
+ if rc /= ((-1)::Int)
then return ()
else fail
else fail
fail = syserr "setFdOption"
setFdOption fd other val = do
- flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
- if flags >= 0 then do
+ flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
+ if flags >= (0::Int) then do
rc <- (if val then
_casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
else do
_casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
- if rc /= -1
+ if rc /= ((-1)::Int)
then return ()
else fail
else fail
getLock fd lock = do
flock <- lock2Bytes lock
rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
- if rc /= -1
+ if rc /= ((-1)::Int)
then do
result <- bytes2ProcessIDAndLock flock
return (maybeResult result)
fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
fdSeek fd mode offset = do
rc <- _ccall_ lseek fd offset (mode2Int mode)
- if rc /= -1
+ if rc /= ((-1)::Int)
then return rc
else syserr "fdSeek"
WriteLock -> ``F_WRLCK''
Unlock -> ``F_UNLCK''
-lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld ())
+lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int)
lock2Bytes (kind, mode, start, len) = do
bytes <- allocChars ``sizeof(struct flock)''
_casm_ ``do { struct flock *fl = (struct flock *)%0;
return bytes
-- where
-bytes2ProcessIDAndLock :: MutableByteArray s () -> IO (ProcessID, FileLock)
+bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock)
bytes2ProcessIDAndLock bytes = do
ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
return (lpid, (kind ltype, mode lwhence, lstart, llen))
--- where
+
kind :: Int -> LockRequest
kind x
| x == ``F_RDLCK'' = ReadLock
| x == ``F_WRLCK'' = WriteLock
| x == ``F_UNLCK'' = Unlock
+
mode :: Int -> SeekMode
mode x
| x == ``SEEK_SET'' = AbsoluteSeek
projects / ghc-hetmet.git / blobdiff