Moved PosixUtil marshaling funs into CString; adjusted imports; don't use lit-lits containing NULL when we've got Addr.nullAddr
) where
import ST
-import PackedString (psToByteArrayST)
import PrelIOBase
import Addr
import IO
import PosixUtil
-import Util ( unvectorize )
+import CString ( unvectorize, strcpy, packStringIO )
+\end{code}
+
+
+\begin{code}
data GroupEntry =
GroupEntry {
getGroupEntryForID :: GroupID -> IO GroupEntry
-getGroupEntryForID gid =
- _ccall_ getgrgid gid >>= \ ptr ->
- if ptr == (``NULL'' :: Addr) then
+getGroupEntryForID gid = do
+ ptr <- _ccall_ getgrgid gid
+ if ptr == nullAddr then
fail (IOError Nothing NoSuchThing
"getGroupEntryForID" "no such group entry")
- else
+ else
unpackGroupEntry ptr
getGroupEntryForName :: String -> IO GroupEntry
-getGroupEntryForName name =
- stToIO (psToByteArrayST name) >>= \ gname ->
- _ccall_ getgrnam gname >>= \ ptr ->
- if ptr == (``NULL'' :: Addr) then
+getGroupEntryForName name = do
+ gname <- packStringIO name
+ ptr <- _ccall_ getgrnam gname
+ if ptr == nullAddr then
fail (IOError Nothing NoSuchThing
"getGroupEntryForName" "no such group entry")
- else
+ else
unpackGroupEntry ptr
getUserEntryForID :: UserID -> IO UserEntry
-getUserEntryForID uid =
- _ccall_ getpwuid uid >>= \ ptr ->
- if ptr == ``NULL'' then
+getUserEntryForID uid = do
+ ptr <- _ccall_ getpwuid uid
+ if ptr == nullAddr then
fail (IOError Nothing NoSuchThing
"getUserEntryForID" "no such user entry")
- else
+ else
unpackUserEntry ptr
getUserEntryForName :: String -> IO UserEntry
-getUserEntryForName name =
- stToIO (psToByteArrayST name) >>= \ uname ->
- _ccall_ getpwnam uname >>= \ ptr ->
- if ptr == ``NULL'' then
+getUserEntryForName name = do
+ uname <- packStringIO name
+ ptr <- _ccall_ getpwnam uname
+ if ptr == nullAddr then
fail (IOError Nothing NoSuchThing
"getUserEntryForName" "no such user entry")
- else
+ else
unpackUserEntry ptr
\end{code}
import ST
import PrelIOBase
import IO
-import IOExts (unsafePerformIO)
-import PackedString (psToByteArrayST)
+import IOExts ( unsafePerformIO )
+import CString ( packStringIO, allocChars,
+ freeze, strcpy
+ )
import Addr
import CCall
import PrelBase
openDirStream :: FilePath -> IO DirStream
openDirStream name =
- psToByteArrayIO name >>= \dir ->
+ packStringIO name >>= \dir ->
_ccall_ opendir dir >>= \dirp@(A# dirp#) ->
- if dirp /= (``NULL''::Addr)
+ if dirp /= nullAddr
then return (DirStream# dirp#)
else syserr "openDirStream"
readDirStream dirp = do
setErrorCode noError
dirent <- _ccall_ readdir dirp
- if dirent /= (``NULL''::Addr)
+ if dirent /= nullAddr
then do
str <- _casm_ ``%r = ((struct dirent *)%0)->d_name;'' dirent
name <- strcpy str
-> OpenFileFlags
-> IO Fd
openFd name how maybe_mode (OpenFileFlags append exclusive noctty nonBlock truncate) =
- psToByteArrayIO name >>= \file ->
+ packStringIO name >>= \file ->
_ccall_ open file flags mode_w >>= \fd@(I# fd#) ->
if fd /= -1
then return (FD# fd#)
createFile :: FilePath -> FileMode -> IO Fd
createFile name mode =
- psToByteArrayIO name >>= \file ->
+ packStringIO name >>= \file ->
_ccall_ creat file mode >>= \fd@(I# fd#) ->
if fd /= -1
then return (FD# fd#)
createLink :: FilePath -> FilePath -> IO ()
createLink name1 name2 = do
- path1 <- psToByteArrayIO name1
- path2 <- psToByteArrayIO name2
+ path1 <- packStringIO name1
+ path2 <- packStringIO name2
rc <- _ccall_ link path1 path2
if rc == 0
then return ()
createDirectory :: FilePath -> FileMode -> IO ()
createDirectory name mode = do -- NB: diff signature from LibDirectory one!
- dir <- psToByteArrayIO name
+ dir <- packStringIO name
rc <- _ccall_ mkdir dir mode
if rc == 0
then return ()
createNamedPipe :: FilePath -> FileMode -> IO ()
createNamedPipe name mode = do
- pipe <- psToByteArrayIO name
+ pipe <- packStringIO name
rc <-_ccall_ mkfifo pipe mode
if rc == 0
then return ()
removeLink :: FilePath -> IO ()
removeLink name = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <-_ccall_ unlink path
if rc == 0
then return ()
rename :: FilePath -> FilePath -> IO ()
rename name1 name2 = do
- path1 <- psToByteArrayIO name1
- path2 <- psToByteArrayIO name2
+ path1 <- packStringIO name1
+ path2 <- packStringIO name2
rc <- _ccall_ rename path1 path2
if rc == 0
then return ()
else syserr "rename"
-type FileStatus = ByteArray ()
+type FileStatus = ByteArray Int
type FileID = Int
type DeviceID = Int
getFileStatus :: FilePath -> IO FileStatus
getFileStatus name = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
bytes <- allocChars ``sizeof(struct stat)''
rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
if rc == 0
fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
fileAccess name read write exec = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _ccall_ access path flags
return (rc == 0)
where
fileExist :: FilePath -> IO Bool
fileExist name = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _ccall_ access path (``F_OK''::Int)
return (rc == 0)
setFileMode :: FilePath -> FileMode -> IO ()
setFileMode name mode = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _ccall_ chmod path mode
if rc == 0
then return ()
setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup name uid gid = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _ccall_ chown path uid gid
if rc == 0
then return ()
setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
setFileTimes name atime mtime = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0;
ub.modtime = (time_t) %1;
%r = utime(%2, &ub);} while(0);'' atime mtime path
{- Set access and modification time to current time -}
touchFile :: FilePath -> IO ()
touchFile name = do
- path <- psToByteArrayIO name
- rc <- _ccall_ utime path (``NULL''::Addr)
+ path <- packStringIO name
+ rc <- _ccall_ utime path nullAddr
if rc == 0
then return ()
else syserr "touchFile"
pathconf :: Int -> FilePath -> IO Limit
pathconf n name = do
- path <- psToByteArrayIO name
+ path <- packStringIO name
rc <- _ccall_ pathconf path n
if rc /= -1
then return rc
) where
import GlaExts
-import ST
import PrelIOBase
import PrelHandle (readHandle, writeHandle, newHandle, getBMode__, getHandleFd )
import IO
-import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST )
import Addr
import Foreign
+import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
import PosixUtil
import PosixFiles ( stdInput, stdOutput, stdError )
0 -> fail (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
then return rc
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
import PrelArr (ByteArray(..)) -- see internals
import PrelIOBase
import IO
+import Addr ( nullAddr )
import PosixErr
import PosixUtil
+import CString ( strcpy, allocWords, freeze, allocChars )
+\end{code}
+
+\begin{code}
getProcessID :: IO ProcessID
getProcessID = _ccall_ getpid
getLoginName :: IO String
getLoginName = do
str <- _ccall_ getlogin
- if str == ``NULL''
+ if str == nullAddr
then syserr "getLoginName"
else strcpy str
#if !defined(cygwin32_TARGET_OS)
getGroups :: IO [GroupID]
getGroups = do
- ngroups <- _ccall_ getgroups 0 (``NULL''::Addr)
+ ngroups <- _ccall_ getgroups 0 nullAddr
words <- allocWords ngroups
ngroups <- _casm_ ``%r = getgroups(%0,(gid_t *)%1);'' ngroups words
if ngroups /= -1
strcpy str
{- OLD:
- str <- _ccall_ cuserid (``NULL''::Addr)
- if str == ``NULL''
+ str <- _ccall_ cuserid nullAddr
+ if str == nullAddr
then syserr "getEffectiveUserName"
else strcpy str
-}
then return pgid
else syserr "createSession"
-type SystemID = ByteArray ()
+type SystemID = ByteArray Int
systemName :: SystemID -> String
systemName sid = unsafePerformIO $ do
epochTime :: IO EpochTime
epochTime = do
- secs <- _ccall_ time (``NULL''::Addr)
+ secs <- _ccall_ time nullAddr
if secs /= -1
then return secs
else syserr "epochTime"
-- All times in clock ticks (see getClockTick)
-type ProcessTimes = (ClockTick, ByteArray ())
+type ProcessTimes = (ClockTick, ByteArray Int)
elapsedTime :: ProcessTimes -> ClockTick
elapsedTime (realtime, _) = realtime
#if !defined(cygwin32_TARGET_OS)
getControllingTerminalName :: IO FilePath
getControllingTerminalName = do
- str <- _ccall_ ctermid (``NULL''::Addr)
- if str == ``NULL''
+ str <- _ccall_ ctermid nullAddr
+ if str == nullAddr
then fail (IOError Nothing NoSuchThing "getControllingTerminalName" "no controlling terminal")
else strcpy str
#endif
getTerminalName :: Fd -> IO FilePath
getTerminalName fd = do
str <- _ccall_ ttyname fd
- if str == ``NULL''
+ if str == nullAddr
then do
err <- try (queryTerminal fd)
either (\err -> syserr "getTerminalName")
import GlaExts
import IO
import PrelIOBase
-import PackedString (psToByteArrayST)
-import Foreign -- stable pointers
+import Foreign ( makeStablePtr, StablePtr, deRefStablePtr )
+import Addr ( nullAddr )
+
import PosixErr
import PosixUtil
-import Util ( unvectorize )
+import CString ( unvectorize, packStringIO,
+ allocChars, freeze, vectorize,
+ allocWords, strcpy
+ )
import System(ExitCode(..))
import PosixProcEnv (getProcessID)
-> Maybe [(String, String)] -- Environment
-> IO ()
executeFile path search args Nothing = do
- prog <- psToByteArrayIO path
+ prog <- packStringIO path
argv <- vectorize (basename path:args)
(if search then
_casm_ ``execvp(%0,(char **)%1);'' prog argv
syserr "executeFile"
executeFile path search args (Just env) = do
- prog <- psToByteArrayIO path
+ prog <- packStringIO path
argv <- vectorize (basename path:args)
envp <- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
(if search then
getEnvVar :: String -> IO String
getEnvVar name = do
- str <- psToByteArrayIO name
+ str <- packStringIO name
str <- _ccall_ getenv str
- if str == ``NULL''
+ if str == nullAddr
then fail (IOError Nothing NoSuchThing
"getEnvVar" "no such environment variable")
else strcpy str
setEnvVar :: String -> String -> IO ()
setEnvVar name value = do
- str <- psToByteArrayIO (name ++ ('=' : value))
+ str <- packStringIO (name ++ ('=' : value))
nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"
removeEnvVar :: String -> IO ()
removeEnvVar name = do
- str <- psToByteArrayIO name
+ str <- packStringIO name
nonzero_error (_ccall_ delenv str) "removeEnvVar"
type Signal = Int
| Ignore
| Catch (IO ())
-type SignalSet = ByteArray ()
+type SignalSet = ByteArray Int
sigSetSize :: Int
sigSetSize = ``sizeof(sigset_t)''
import PosixUtil
import PosixErr
+import CString ( freeze, allocChars )
-type TerminalAttributes = ByteArray ()
+\end{code}
+
+\begin{code}
+type TerminalAttributes = ByteArray Int
data TerminalMode = InterruptOnBreak
| MapCRtoLF
\begin{code}
module PosixUtil where
-import ST
-import PrelST -- ST representation
+import GlaExts
import PrelIOBase -- IOError representation
-import Addr
-import Foreign
-import CCall
-import PrelAddr
-import PrelBase ( Int(..), Int#, (==#)
- , newIntArray#, unsafeFreezeByteArray#, newCharArray#
- , RealWorld
- )
-
-import MutableArray
-import ByteArray
-import Array
-import PackedString ( unpackCStringIO, packCBytesST, psToByteArrayST )
-import Ix
-import PrelArr (StateAndMutableByteArray#(..), StateAndByteArray#(..))
-import Util ( unvectorize )
\end{code}
str
"")
--- Allocate a mutable array of characters with no indices.
-
-allocChars :: Int -> IO (MutableByteArray RealWorld ())
-allocChars (I# size#) = IO $ \ s# ->
- case newCharArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bot barr#)
- where
- bot = error "PosixUtil.allocChars"
-
--- Allocate a mutable array of words with no indices
-
-allocWords :: Int -> IO (MutableByteArray RealWorld ())
-allocWords (I# size#) = IO $ \ s# ->
- case newIntArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bot barr#)
- where
- bot = error "PosixUtil.allocWords"
-
--- Freeze these index-free mutable arrays
-
-freeze :: MutableByteArray RealWorld () -> IO (ByteArray ())
-freeze (MutableByteArray ixs arr#) = IO $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of
- StateAndByteArray# s2# frozen# ->
- IOok s2# (ByteArray ixs frozen#)
-
--- Copy a null-terminated string from outside the heap to
--- Haskellized nonsense inside the heap
-
-strcpy :: Addr -> IO String
-strcpy str = unpackCStringIO str
-
--- Turn a string list into a NULL-terminated vector of null-terminated
--- strings No indices...I hate indices. Death to Ix.
-
-vectorize :: [String] -> IO (ByteArray ())
-vectorize xs = do
- arr <- allocWords (len + 1)
- fill arr 0 xs
- freeze arr
- where
- len :: Int
- len = length xs
-
- fill :: MutableByteArray RealWorld () -> Int -> [String] -> IO ()
- fill arr n [] =
- _casm_ ``((PP_)%0)[%1] = NULL;'' arr n
- fill arr n (x:xs) =
- stToIO (psToByteArrayST x) >>= \ barr ->
- _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr
- >>= \ () ->
- fill arr (n+1) xs
-
--- Turn a NULL-terminated vector of null-terminated strings into a string list
--- unvectorize ... (now in misc/Util.lhs)
-
-- common templates for system calls
nonzero_error :: IO Int -> String -> IO ()
then return ()
else syserr err
--- IO versions of a few ST functions.
-
-psToByteArrayIO = stToIO . psToByteArrayST
-
\end{code}
projects / ghc-hetmet.git / commitdiff