diff options
| -rw-r--r-- | Makefile | 4 | ||||
| -rw-r--r-- | System/Posix.hs | 7 | ||||
| -rw-r--r-- | System/Posix/Files.hsc | 111 | ||||
| -rw-r--r-- | System/Posix/IO.hsc | 327 | ||||
| -rw-r--r-- | System/Posix/Process.hsc | 351 | ||||
| -rw-r--r-- | System/Posix/Unistd.hsc | 181 | ||||
| -rw-r--r-- | cbits/HsUnix.c | 12 | ||||
| -rw-r--r-- | cbits/Makefile | 12 | ||||
| -rw-r--r-- | cbits/execvpe.c | 172 | ||||
| -rw-r--r-- | include/HsUnix.h | 32 | ||||
| -rw-r--r-- | include/Makefile | 9 | ||||
| -rw-r--r-- | unix.conf.in | 11 |
12 files changed, 1035 insertions, 194 deletions
@@ -1,10 +1,14 @@ TOP=.. include $(TOP)/mk/boilerplate.mk +SUBDIRS = cbits include + ALL_DIRS = System System/Posix PACKAGE = unix PACKAGE_DEPS = base SRC_HADDOCK_OPTS += -t "Haskell Core Libraries (unix package)" +SRC_HSC2HS_OPTS += -Iinclude +SRC_HC_OPTS += -Iinclude include $(TOP)/mk/target.mk diff --git a/System/Posix.hs b/System/Posix.hs index 9d4d244..fa4ac6d 100644 --- a/System/Posix.hs +++ b/System/Posix.hs @@ -18,9 +18,9 @@ module System.Posix ( module System.Posix.Directory, module System.Posix.Files, module System.Posix.Unistd, - -- module System.Posix.IO, + module System.Posix.IO, + module System.Posix.Process, -- module System.Posix.Time, - -- module System.Posix.Proc, ) where import System.Posix.Types @@ -28,3 +28,6 @@ import System.Posix.Signals import System.Posix.Directory import System.Posix.Files import System.Posix.Unistd +import System.Posix.Process +import System.Posix.IO + diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index 9dc5555..69e4924 100644 --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -48,6 +48,9 @@ module System.Posix.Files ( -- * Hard links createLink, removeLink, + -- * Symbolic links + createSymbolicLink, readSymbolicLink, + -- * Renaming files rename, @@ -57,14 +60,8 @@ module System.Posix.Files ( -- * Changing file timestamps setFileTimes, touchFile, - -- * Standard file descriptors - stdInput, stdOutput, stdError, - - -- * Opening and closing files - OpenMode(..), - OpenFileFlags(..), defaultFileFlags, - openFd, createFile, - closeFd, + -- * Setting file sizes + setFileSize, setFdSize, {- -- run-time limit & POSIX feature testing @@ -86,6 +83,7 @@ import Foreign.C #include <unistd.h> #include <utime.h> #include <fcntl.h> +#include <limits.h> -- ----------------------------------------------------------------------------- -- POSIX file modes @@ -334,6 +332,32 @@ removeLink name = throwErrnoIfMinus1_ "removeLink" (c_unlink s) -- ----------------------------------------------------------------------------- +-- Symbolic Links + +createSymbolicLink :: FilePath -> FilePath -> IO () +createSymbolicLink file1 file2 = + withCString file1 $ \s1 -> + withCString file2 $ \s2 -> + throwErrnoIfMinus1_ "createSymbolicLink" (c_symlink s1 s2) + +foreign import ccall unsafe "symlink" + c_symlink :: CString -> CString -> IO CInt + +-- ToDo: should really use SYMLINK_MAX, but not everyone supports it yet, +-- and it seems that the intention is that SYMLINK_MAX is no larger than +-- PATH_MAX. +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 (#const PATH_MAX) $ \buf -> do + withCString file $ \s -> + throwErrnoIfMinus1_ "readSymbolicLink" $ + c_readlink s buf (#const PATH_MAX) + peekCString buf + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- -- Renaming files rename :: FilePath -> FilePath -> IO () @@ -385,67 +409,20 @@ touchFile name = do throwErrnoIfMinus1_ "touchFile" (c_utime s nullPtr) -- ----------------------------------------------------------------------------- --- opening files - -stdInput, stdOutput, stdError :: Fd -stdInput = Fd (#const STDIN_FILENO) -stdOutput = Fd (#const STDOUT_FILENO) -stdError = Fd (#const STDERR_FILENO) - -data OpenMode = ReadOnly | WriteOnly | ReadWrite - -data OpenFileFlags = - OpenFileFlags { - append :: Bool, - exclusive :: Bool, - noctty :: Bool, - nonBlock :: Bool, - trunc :: Bool - } - -defaultFileFlags :: OpenFileFlags -defaultFileFlags = - OpenFileFlags { - append = False, - exclusive = False, - noctty = False, - nonBlock = False, - trunc = False - } - -openFd :: FilePath - -> OpenMode - -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist - -> OpenFileFlags - -> IO Fd -openFd name how maybe_mode (OpenFileFlags append exclusive noctty - nonBlock truncate) = do - withCString name $ \s -> do - fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) - return (Fd fd) - where - all_flags = creat .|. flags .|. open_mode - - flags = - (if append then (#const O_APPEND) else 0) .|. - (if exclusive then (#const O_EXCL) else 0) .|. - (if noctty then (#const O_NOCTTY) else 0) .|. - (if nonBlock then (#const O_NONBLOCK) else 0) .|. - (if truncate then (#const O_TRUNC) else 0) +-- Setting file sizes - (creat, mode_w) = case maybe_mode of - Nothing -> (0,0) - Just x -> ((#const O_CREAT), x) +setFileSize :: FilePath -> FileOffset -> IO () +setFileSize file off = + withCString file $ \s -> + throwErrnoIfMinus1_ "setFileSize" (c_truncate s off) - open_mode = case how of - ReadOnly -> (#const O_RDONLY) - WriteOnly -> (#const O_WRONLY) - ReadWrite -> (#const O_RDWR) +foreign import ccall unsafe "truncate" + c_truncate :: CString -> COff -> IO CInt +setFdSize :: Fd -> FileOffset -> IO () +setFdSize fd off = + throwErrnoIfMinus1_ "setFdSize" (c_ftruncate fd off) -createFile :: FilePath -> FileMode -> IO Fd -createFile name mode - = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } +foreign import ccall unsafe "ftruncate" + c_ftruncate :: Fd -> COff -> IO CInt -closeFd :: Fd -> IO () -closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc new file mode 100644 index 0000000..f324841 --- /dev/null +++ b/System/Posix/IO.hsc @@ -0,0 +1,327 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.IO +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX IO support +-- +----------------------------------------------------------------------------- + +module System.Posix.IO ( + -- * Input \/ Output + + -- ** Standard file descriptors + stdInput, stdOutput, stdError, + + -- ** Opening and closing files + OpenMode(..), + OpenFileFlags(..), defaultFileFlags, + openFd, createFile, + closeFd, + + -- ** Reading/writing data +{- + fdRead, fdWrite, +-} + + -- ** Seeking + fdSeek, + + -- ** File options + FdOption(..), + queryFdOption, + setFdOption, + + -- ** Locking + FileLock, + LockRequest(..), + getLock, setLock, + waitToSetLock, + + -- ** Pipes + createPipe, + + -- ** Duplicating file descriptors + dup, dupTo, + + -- ** Converting file descriptors to/from Handles + handleToFd, fdToHandle, + + ) where + +import System.IO +import System.IO.Error +import System.Posix.Types +import Control.Exception ( throw ) + +import Foreign +import Foreign.C +import Data.Bits + +#ifdef __GLASGOW_HASKELL__ +import GHC.IOBase +import GHC.Handle hiding (fdToHandle, openFd) +import qualified GHC.Handle +#endif + +#include <unistd.h> +#include <fcntl.h> + +-- ----------------------------------------------------------------------------- +-- Pipes + +createPipe :: IO (Fd, Fd) +createPipe = + allocaArray 2 $ \p_fd -> do + throwErrnoIfMinus1_ "createPipe" (c_pipe p_fd) + rfd <- peekElemOff p_fd 0 + wfd <- peekElemOff p_fd 1 + return (rfd, wfd) + +foreign import ccall unsafe "pipe" + c_pipe :: Ptr Fd -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Duplicating file descriptors + +dup :: Fd -> IO Fd +dup fd = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r) + +foreign import ccall unsafe "dup" + c_dup :: Fd -> IO CInt + +dupTo :: Fd -> Fd -> IO Fd +dupTo fd1 fd2 = throwErrnoIfMinus1 "dupTp" (c_dup2 fd1 fd2) + +foreign import ccall unsafe "dup2" + c_dup2 :: Fd -> Fd -> IO Fd + +-- ----------------------------------------------------------------------------- +-- Opening and closing files + +stdInput, stdOutput, stdError :: Fd +stdInput = Fd (#const STDIN_FILENO) +stdOutput = Fd (#const STDOUT_FILENO) +stdError = Fd (#const STDERR_FILENO) + +data OpenMode = ReadOnly | WriteOnly | ReadWrite + +data OpenFileFlags = + OpenFileFlags { + append :: Bool, + exclusive :: Bool, + noctty :: Bool, + nonBlock :: Bool, + trunc :: Bool + } + +defaultFileFlags :: OpenFileFlags +defaultFileFlags = + OpenFileFlags { + append = False, + exclusive = False, + noctty = False, + nonBlock = False, + trunc = False + } + +openFd :: FilePath + -> OpenMode + -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist + -> OpenFileFlags + -> IO Fd +openFd name how maybe_mode (OpenFileFlags append exclusive noctty + nonBlock truncate) = do + withCString name $ \s -> do + fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) + return (Fd fd) + where + all_flags = creat .|. flags .|. open_mode + + flags = + (if append then (#const O_APPEND) else 0) .|. + (if exclusive then (#const O_EXCL) else 0) .|. + (if noctty then (#const O_NOCTTY) else 0) .|. + (if nonBlock then (#const O_NONBLOCK) else 0) .|. + (if truncate then (#const O_TRUNC) else 0) + + (creat, mode_w) = case maybe_mode of + Nothing -> (0,0) + Just x -> ((#const O_CREAT), x) + + open_mode = case how of + ReadOnly -> (#const O_RDONLY) + WriteOnly -> (#const O_WRONLY) + ReadWrite -> (#const O_RDWR) + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> CMode -> IO CInt + +createFile :: FilePath -> FileMode -> IO Fd +createFile name mode + = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } + +closeFd :: Fd -> IO () +closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) + +foreign import ccall unsafe "close" + c_close :: CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Converting file descriptors to/from Handles + +#ifdef __GLASGOW_HASKELL__ +handleToFd :: Handle -> IO Fd +handleToFd h = withHandle "handleToFd" h $ \ h_ -> do + -- converting a Handle into an Fd effectively means + -- letting go of the Handle; it is put into a closed + -- state as a result. + let fd = haFD h_ + flushWriteBufferOnly h_ + unlockFile (fromIntegral fd) + -- setting the Handle's fd to (-1) as well as its 'type' + -- to closed, is enough to disable the finalizer that + -- eventually is run on the Handle. + return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd)) + +fdToHandle :: Fd -> IO Handle +fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd) +#endif + +-- ----------------------------------------------------------------------------- +-- Fd options + +data FdOption = AppendOnWrite + | CloseOnExec + | NonBlockingRead + | SynchronousWrites + +queryFdOption :: Fd -> FdOption -> IO Bool +queryFdOption fd opt = do + r <- throwErrnoIfMinus1 "queryFdOption" (c_fcntl_read fd flag) + return ((r .&. opt_val) /= 0) + where + flag = case opt of + CloseOnExec -> (#const F_GETFD) + other -> (#const F_GETFL) + + opt_val = case opt of + CloseOnExec -> (#const FD_CLOEXEC) + AppendOnWrite -> (#const O_APPEND) + NonBlockingRead -> (#const O_NONBLOCK) + SynchronousWrites -> (#const O_SYNC) + +foreign import ccall unsafe "fcntl" + c_fcntl_read :: Fd -> CInt -> IO CInt + +setFdOption :: Fd -> FdOption -> Bool -> IO () +setFdOption fd opt val = do + r <- throwErrnoIfMinus1 "setFdOption" (c_fcntl_read fd flag) + let r' | val = r .|. opt_val + | otherwise = r .&. (complement opt_val) + throwErrnoIfMinus1_ "setFdOption" (c_fcntl_write fd flag r') + where + flag = case opt of + CloseOnExec -> (#const F_GETFD) + other -> (#const F_GETFL) + opt_val = case opt of + CloseOnExec -> (#const FD_CLOEXEC) + AppendOnWrite -> (#const O_APPEND) + NonBlockingRead -> (#const O_NONBLOCK) + SynchronousWrites -> (#const O_SYNC) + +foreign import ccall unsafe "fcntl" + c_fcntl_write :: Fd -> CInt -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Seeking + +mode2Int :: SeekMode -> CInt +mode2Int AbsoluteSeek = (#const SEEK_SET) +mode2Int RelativeSeek = (#const SEEK_CUR) +mode2Int SeekFromEnd = (#const SEEK_END) + +fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset +fdSeek fd mode off = + throwErrnoIfMinus1 "fdSeek" (c_lseek fd off (mode2Int mode)) + +foreign import ccall unsafe "lseek" + c_lseek :: Fd -> COff -> CInt -> IO COff + +-- ----------------------------------------------------------------------------- +-- Locking + +data LockRequest = ReadLock + | WriteLock + | Unlock + +type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset) + +type CFLock = () + +getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock)) +getLock fd lock = + allocaLock lock $ \p_flock -> do + throwErrnoIfMinus1_ "getLock" (c_fcntl_flock fd (#const F_GETLK) p_flock) + result <- bytes2ProcessIDAndLock p_flock + return (maybeResult result) + where + maybeResult (_, (Unlock, _, _, _)) = Nothing + maybeResult x = Just x + +foreign import ccall unsafe "fcntl" + c_fcntl_flock :: Fd -> CInt -> Ptr CFLock -> IO CInt + +allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a +allocaLock (lockreq, mode, start, len) io = + allocaBytes (#const sizeof(struct flock)) $ \p -> do + (#poke struct flock, l_type) p (lockReqToInt lockreq :: CShort) + (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort) + (#poke struct flock, l_start) p start + (#poke struct flock, l_len) p len + io p + +lockReqToInt :: LockRequest -> CShort +lockReqToInt ReadLock = (#const F_RDLCK) +lockReqToInt WriteLock = (#const F_WRLCK) +lockReqToInt Unlock = (#const F_UNLCK) + +bytes2ProcessIDAndLock :: Ptr CFLock -> IO (ProcessID, FileLock) +bytes2ProcessIDAndLock p = do + req <- (#peek struct flock, l_type) p + mode <- (#peek struct flock, l_whence) p + start <- (#peek struct flock, l_start) p + len <- (#peek struct flock, l_len) p + pid <- (#peek struct flock, l_pid) p + return (pid, (int2req req, int2mode mode, start, len)) + where + int2req :: CShort -> LockRequest + int2req (#const F_RDLCK) = ReadLock + int2req (#const F_WRLCK) = WriteLock + int2req (#const F_UNLCK) = Unlock + int2req _ = throw (mkIOError illegalOperationErrorType "int2req" + Nothing Nothing) + + int2mode :: CShort -> SeekMode + int2mode (#const SEEK_SET) = AbsoluteSeek + int2mode (#const SEEK_CUR) = RelativeSeek + int2mode (#const SEEK_END) = SeekFromEnd + int2mode _ = throw (mkIOError illegalOperationErrorType "int2mode" + Nothing Nothing) + +setLock :: Fd -> FileLock -> IO () +setLock fd lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "setLock" (c_fcntl_flock fd (#const F_SETLK) p_flock) + +waitToSetLock :: Fd -> FileLock -> IO () +waitToSetLock fd lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "waitToSetLock" + (c_fcntl_flock fd (#const F_SETLKW) p_flock) diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc new file mode 100644 index 0000000..dfa9e9a --- /dev/null +++ b/System/Posix/Process.hsc @@ -0,0 +1,351 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Process +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX process support +-- +----------------------------------------------------------------------------- + +module System.Posix.Process ( + -- * Processes + + -- ** Forking and executing + forkProcess, executeFile, + + -- ** Exiting + exitImmediately, + + -- ** Process environment + getProcessID, + getParentProcessID, + getProcessGroupID, + + -- ** Process groups + createProcessGroup, + joinProcessGroup, + setProcessGroupID, + + -- ** Sessions + createSession, + + -- ** Process times + ProcessTimes(elapsedTime, systemTime, userTime, + childSystemTime, childUserTime), + getProcessTimes, + + -- ** Scheduling priority + nice, + getProcessPriority, + getProcessGroupPriority, + getUserPriority, + setProcessPriority, + setProcessGroupPriority, + setUserPriority, + + -- ** Process status + ProcessStatus(..), + getProcessStatus, + getAnyProcessStatus, + getGroupProcessStatus, + +-- ToDo: +-- getEnvVar, +-- getEnvironment, + ) where + +#include "HsUnix.h" +#include <sys/times.h> + +import Foreign +import Foreign.C +import System.IO +import System.IO.Error +import System.Exit +import System.Posix.Types +import System.Posix.Signals + +-- ----------------------------------------------------------------------------- +-- Process environment + +getProcessID :: IO ProcessID +getProcessID = c_getpid + +foreign import ccall unsafe "getpid" + c_getpid :: IO CPid + +getParentProcessID :: IO ProcessID +getParentProcessID = c_getppid + +foreign import ccall unsafe "getppid" + c_getppid :: IO CPid + +getProcessGroupID :: IO ProcessGroupID +getProcessGroupID = c_getpgrp + +foreign import ccall unsafe "getpgrp" + c_getpgrp :: IO CPid + +createProcessGroup :: ProcessID -> IO ProcessGroupID +createProcessGroup pid = do + throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) + return pid + +joinProcessGroup :: ProcessGroupID -> IO () +joinProcessGroup pgid = + throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid) + +setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () +setProcessGroupID pid pgid = + throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) + +foreign import ccall unsafe "setpgid" + c_setpgid :: CPid -> CPid -> IO CInt + +createSession :: IO ProcessGroupID +createSession = throwErrnoIfMinus1 "createSession" c_setsid + +foreign import ccall unsafe "setsid" + c_setsid :: IO CPid + +-- ----------------------------------------------------------------------------- +-- Process times + +-- All times in clock ticks (see getClockTick) + +data ProcessTimes + = ProcessTimes { elapsedTime :: ClockTick + , userTime :: ClockTick + , systemTime :: ClockTick + , childUserTime :: ClockTick + , childSystemTime :: ClockTick + } + +getProcessTimes :: IO ProcessTimes +getProcessTimes = do + allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do + elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms) + ut <- (#peek struct tms, tms_utime) p_tms + st <- (#peek struct tms, tms_stime) p_tms + cut <- (#peek struct tms, tms_cutime) p_tms + cst <- (#peek struct tms, tms_cstime) p_tms + return (ProcessTimes{ elapsedTime = elapsed, + userTime = ut, + systemTime = st, + childUserTime = cut, + childSystemTime = cst + }) + +type CTms = () + +foreign import ccall unsafe "times" + c_times :: Ptr CTms -> IO CClock + +-- ----------------------------------------------------------------------------- +-- Process scheduling priority + +nice :: Int -> IO () +nice prio = throwErrnoIfMinus1_ "nice" (c_nice (fromIntegral prio)) + +foreign import ccall unsafe "nice" + c_nice :: CInt -> IO CInt + +getProcessPriority :: ProcessID -> IO Int +getProcessGroupPriority :: ProcessGroupID -> IO Int +getUserPriority :: UserID -> IO Int + +getProcessPriority pid = do + r <- throwErrnoIfMinus1 "getProcessPriority" $ + c_getpriority (#const PRIO_PROCESS) (fromIntegral pid) + return (fromIntegral r) + +getProcessGroupPriority pid = do + r <- throwErrnoIfMinus1 "getProcessPriority" $ + c_getpriority (#const PRIO_PGRP) (fromIntegral pid) + return (fromIntegral r) + +getUserPriority uid = do + r <- throwErrnoIfMinus1 "getUserPriority" $ + c_getpriority (#const PRIO_USER) (fromIntegral uid) + return (fromIntegral r) + +foreign import ccall unsafe "getpriority" + c_getpriority :: CInt -> CInt -> IO CInt + +setProcessPriority :: ProcessID -> Int -> IO () +setProcessGroupPriority :: ProcessGroupID -> Int -> IO () +setUserPriority :: UserID -> Int -> IO () + +setProcessPriority pid val = + throwErrnoIfMinus1_ "setProcessPriority" $ + c_setpriority (#const PRIO_PROCESS) (fromIntegral pid) (fromIntegral val) + +setProcessGroupPriority pid val = + throwErrnoIfMinus1_ "setProcessPriority" $ + c_setpriority (#const PRIO_PGRP) (fromIntegral pid) (fromIntegral val) + +setUserPriority uid val = + throwErrnoIfMinus1_ "setUserPriority" $ + c_setpriority (#const PRIO_USER) (fromIntegral uid) (fromIntegral val) + +foreign import ccall unsafe "setpriority" + c_setpriority :: CInt -> CInt -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Forking, execution + +forkProcess :: IO (Maybe ProcessID) +forkProcess = do + r <- throwErrnoIfMinus1 "forkProcess" c_fork + case r of + 0 -> return Nothing + pid -> return (Just (fromIntegral pid)) + +foreign import ccall unsafe "fork" + c_fork :: IO CInt + + +executeFile :: FilePath -- Command + -> Bool -- Search PATH? + -> [String] -- Arguments + -> Maybe [(String, String)] -- Environment + -> IO () +executeFile path search args Nothing = do + withCString path $ \s -> + withMany withCString args $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> + if search then + throwErrnoIfMinus1_ "executeFile" (c_execvp s arr) + else + throwErrnoIfMinus1_ "executeFile" (c_execv s arr) + +executeFile path search args (Just env) = do + withCString path $ \s -> + withMany withCString args $ \cstrs -> + withArray0 nullPtr cstrs $ \arg_arr -> + let env' = map (\ (name, val) -> name ++ ('=' : val)) env in + withMany withCString env' $ \cenv -> + withArray0 nullPtr cenv $ \env_arr -> + if search then + throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr) + else + throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr) + +foreign import ccall unsafe "execvp" + c_execvp :: CString -> Ptr CString -> IO CInt + +foreign import ccall unsafe "execv" + c_execv :: CString -> Ptr CString -> IO CInt + +foreign import ccall unsafe "execvpe" + c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt + +foreign import ccall unsafe "execve" + c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Waiting for process termination + +data ProcessStatus = Exited ExitCode + | Terminated Signal + | Stopped Signal + deriving (Eq, Ord, Show) + +getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus) +getProcessStatus block stopped pid = + alloca $ \wstatp -> do + pid <- throwErrnoIfMinus1 "getProcessStatus" + (c_waitpid pid wstatp (waitOptions block stopped)) + case pid of + 0 -> return Nothing + _ -> do ps <- decipherWaitStatus wstatp + return (Just ps) + +foreign import ccall unsafe "waitpid" + c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid + +getGroupProcessStatus :: Bool + -> Bool + -> ProcessGroupID + -> IO (Maybe (ProcessID, ProcessStatus)) +getGroupProcessStatus block stopped pgid = + alloca $ \wstatp -> do + pid <- throwErrnoIfMinus1 "getGroupProcessStatus" + (c_waitpid (-pgid) wstatp (waitOptions block stopped)) + case pid of + 0 -> return Nothing + _ -> do ps <- decipherWaitStatus wstatp + return (Just (pid, ps)) + +getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus)) +getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1 + +waitOptions :: Bool -> Bool -> CInt +-- block stopped +waitOptions False False = (#const WNOHANG) +waitOptions False True = (#const (WNOHANG|WUNTRACED)) +waitOptions True False = 0 +waitOptions True True = (#const WUNTRACED) + +-- Turn a (ptr to a) wait status into a ProcessStatus + +decipherWaitStatus :: Ptr CInt -> IO ProcessStatus +decipherWaitStatus wstatp = do + wstat <- peek wstatp + if c_WIFEXITED wstat /= 0 + then do + let exitstatus = c_WEXITSTATUS wstat + if exitstatus == 0 + then return (Exited ExitSuccess) + else return (Exited (ExitFailure (fromIntegral exitstatus))) + else do + if c_WIFSIGNALED wstat /= 0 + then do + let termsig = c_WTERMSIG wstat + return (Terminated (fromIntegral termsig)) + else do + if c_WIFSTOPPED wstat /= 0 + then do + let stopsig = c_WSTOPSIG wstat + return (Stopped (fromIntegral stopsig)) + else do + ioError (mkIOError illegalOperationErrorType + "waitStatus" Nothing Nothing) + +foreign import ccall unsafe "__hsunix_wifexited" + c_WIFEXITED :: CInt -> CInt + +foreign import ccall unsafe "__hsunix_wexitstatus" + c_WEXITSTATUS :: CInt -> CInt + +foreign import ccall unsafe "__hsunix_wifsignaled" + c_WIFSIGNALED :: CInt -> CInt + +foreign import ccall unsafe "__hsunix_wtermsig" + c_WTERMSIG :: CInt -> CInt + +foreign import ccall unsafe "__hsunix_wifstopped" + c_WIFSTOPPED :: CInt -> CInt + +foreign import ccall unsafe "__hsunix_wstopsig" + c_WSTOPSIG :: CInt -> CInt + +-- ----------------------------------------------------------------------------- +-- Exiting + +exitImmediately :: ExitCode -> IO () +exitImmediately exitcode = c_exit (exitcode2Int exitcode) + where + exitcode2Int ExitSuccess = 0 + exitcode2Int (ExitFailure n) = fromIntegral n + +foreign import ccall unsafe "exit" + c_exit :: CInt -> IO () + +-- ----------------------------------------------------------------------------- diff --git a/System/Posix/Unistd.hsc b/System/Posix/Unistd.hsc index a7fae7e..bdcbc34 100644 --- a/System/Posix/Unistd.hsc +++ b/System/Posix/Unistd.hsc @@ -29,52 +29,45 @@ module System.Posix.Unistd ( setUserID, setGroupID, - -- * Process environment - -- ** Querying the process environment - getProcessID, - getParentProcessID, - getProcessGroupID, - - -- ** Process groups - createProcessGroup, - joinProcessGroup, - setProcessGroupID, - - -- ** Sessions - createSession, - - -- ** Process times - ProcessTimes(elapsedTime, systemTime, userTime, - childSystemTime, childUserTime), - getProcessTimes, - -- * System environment SystemID(..), getSystemID, + SysVar(..), + getSysVar, + + -- * Sleeping + sleep, usleep, + {- ToDo from unistd.h: - confstr - dup, dup2, exec*, exit, fork, fpathconf, fsync, ftruncate, - gethostid, gethostname, getlogin, getopt, isatty, lockf, - lseek, nice, pathconf, pipe, pread, pwrite, read, readlink, - sleep, symlink, sysconf, tcgetpgrp, tcsetpgrp, truncate, - ttyname(_r), ualarm, usleep, vfork, write + confstr, + lots of sysconf variables - SysVar(..), - getSysVar, + -- use Network.BSD + gethostid, gethostname -- should be in System.Posix.Files? + pathconf, fpathconf, queryTerminal, getTerminalName, #if !defined(cygwin32_TARGET_OS) getControllingTerminalName, #endif + -- System.Posix.Signals + ualarm, + + -- System.Posix.Terminal + isatty, tcgetpgrp, tcsetpgrp, ttyname(_r), + + -- System.Posix.IO + read, write, + -- should be in System.Posix.Time? epochTime, - -- should be in System.Posix.Pwd? + -- should be in System.Posix.User? getEffectiveUserName, -} ) where @@ -85,7 +78,6 @@ import System.Posix.Types import GHC.Posix #include <unistd.h> -#include <sys/times.h> #include <sys/utsname.h> -- ----------------------------------------------------------------------------- @@ -152,77 +144,6 @@ foreign import ccall unsafe "setgid" c_setgid :: CGid -> IO CInt -- ----------------------------------------------------------------------------- --- Process environment - -getProcessID :: IO ProcessID -getProcessID = c_getpid - -getParentProcessID :: IO ProcessID -getParentProcessID = c_getppid - -foreign import ccall unsafe "getppid" - c_getppid :: IO CPid - -getProcessGroupID :: IO ProcessGroupID -getProcessGroupID = c_getpgrp - -foreign import ccall unsafe "getpgrp" - c_getpgrp :: IO CPid - -createProcessGroup :: ProcessID -> IO ProcessGroupID -createProcessGroup pid = do - throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) - return pid - -joinProcessGroup :: ProcessGroupID -> IO () -joinProcessGroup pgid = - throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid) - -setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () -setProcessGroupID pid pgid = - throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) - -foreign import ccall unsafe "setpgid" - c_setpgid :: CPid -> CPid -> IO CInt - -createSession :: IO ProcessGroupID -createSession = throwErrnoIfMinus1 "createSession" c_setsid - -foreign import ccall unsafe "setsid" - c_setsid :: IO CPid - --- ----------------------------------------------------------------------------- --- Process times - --- All times in clock ticks (see getClockTick) - -data ProcessTimes - = ProcessTimes { elapsedTime :: ClockTick - , userTime :: ClockTick - , systemTime :: ClockTick - , childUserTime :: ClockTick - , childSystemTime :: ClockTick - } - -getProcessTimes :: IO ProcessTimes -getProcessTimes = do - allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do - elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms) - ut <- (#peek struct tms, tms_utime) p_tms - st <- (#peek struct tms, tms_stime) p_tms - cut <- (#peek struct tms, tms_cutime) p_tms - cst <- (#peek struct tms, tms_cstime) p_tms - return (ProcessTimes{ elapsedTime = elapsed, - userTime = ut, - systemTime = st, - childUserTime = cut, - childSystemTime = cst - }) - -foreign import ccall unsafe "times" - c_times :: Ptr CTms -> IO CClock - --- ----------------------------------------------------------------------------- -- System environment (uname()) data SystemID = @@ -249,7 +170,26 @@ getSystemID = do machine = mach }) -{- +-- ----------------------------------------------------------------------------- +-- sleeping + +sleep :: Int -> IO Int +sleep 0 = return 0 +sleep secs = do r <- c_sleep (fromIntegral secs); return (fromIntegral r) + +foreign import ccall unsafe "sleep" + c_sleep :: CUInt -> IO CUInt + +usleep :: Int -> IO () +usleep 0 = return () +usleep usecs = throwErrnoIfMinus1_ "usleep" (c_usleep (fromIntegral usecs)) + +foreign import ccall unsafe "usleep" + c_usleep :: CUInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- System variables + data SysVar = ArgumentLimit | ChildLimit | ClockTick @@ -258,27 +198,24 @@ data SysVar = ArgumentLimit | PosixVersion | HasSavedIDs | HasJobControl + -- ToDo: lots more -getSysVar :: SysVar -> IO Limit +getSysVar :: SysVar -> IO Integer getSysVar v = case v of - ArgumentLimit -> sysconf ``_SC_ARG_MAX'' - ChildLimit -> sysconf ``_SC_CHILD_MAX'' - ClockTick -> sysconf ``_SC_CLK_TCK'' - GroupLimit -> sysconf ``_SC_NGROUPS_MAX'' - OpenFileLimit -> sysconf ``_SC_OPEN_MAX'' - PosixVersion -> sysconf ``_SC_VERSION'' - HasSavedIDs -> sysconf ``_SC_SAVED_IDS'' - HasJobControl -> sysconf ``_SC_JOB_CONTROL'' --- where - -sysconf :: Int -> IO Limit -sysconf n = do - rc <- _ccall_ sysconf n - if rc /= (-1::Int) - then return rc - else ioException (IOError Nothing NoSuchThing - "getSysVar" - "no such system limit or option" - Nothing) --} + ArgumentLimit -> sysconf (#const _SC_ARG_MAX) + ChildLimit -> sysconf (#const _SC_CHILD_MAX) + ClockTick -> sysconf (#const _SC_CLK_TCK) + GroupLimit -> sysconf (#const _SC_NGROUPS_MAX) + OpenFileLimit -> sysconf (#const _SC_OPEN_MAX) + PosixVersion -> sysconf (#const _SC_VERSION) + HasSavedIDs -> sysconf (#const _SC_SAVED_IDS) + HasJobControl -> sysconf (#const _SC_JOB_CONTROL) + +sysconf :: CInt -> IO Integer +sysconf n = do + r <- throwErrnoIfMinus1 "getSysVar" (c_sysconf n) + return (fromIntegral r) + +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> IO CLong diff --git a/cbits/HsUnix.c b/cbits/HsUnix.c new file mode 100644 index 0000000..ebaeed3 --- /dev/null +++ b/cbits/HsUnix.c @@ -0,0 +1,12 @@ +/* ----------------------------------------------------------------------------- + * $Id: HsUnix.c,v 1.1 2002/09/12 16:38:22 simonmar Exp $ + * + * (c) The University of Glasgow 2002 + * + * Definitions for package `unix' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +// Out-of-line versions of all the inline functions from HsUnix.h +#define INLINE /* nothing */ +#include "HsUnix.h" diff --git a/cbits/Makefile b/cbits/Makefile new file mode 100644 index 0000000..e23cd2f --- /dev/null +++ b/cbits/Makefile @@ -0,0 +1,12 @@ +TOP = ../.. +include $(TOP)/mk/boilerplate.mk + +HC = $(GHC_INPLACE) + +SRC_CC_OPTS += -Wall +SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -I../include + +LIBRARY = libHSunix_cbits.a +LIBOBJS = $(C_OBJS) + +include $(TOP)/mk/target.mk diff --git a/cbits/execvpe.c b/cbits/execvpe.c new file mode 100644 index 0000000..9a92169 --- /dev/null +++ b/cbits/execvpe.c @@ -0,0 +1,172 @@ +/* +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996 +% +*/ + +/* Evidently non-Posix. */ +/* #include "PosixSource.h" */ + +#include "HsUnix.h" + +#include <unistd.h> +#include <sys/time.h> +#include <stdlib.h> +#include <string.h> +#include <errno.h> + +/* + * We want the search semantics of execvp, but we want to provide our + * own environment, like execve. The following copyright applies to + * this code, as it is a derivative of execvp: + *- + * Copyright (c) 1991 The Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +int +execvpe(char *name, char **argv, char **envp) +{ + register int lp, ln; + register char *p; + int eacces=0, etxtbsy=0; + char *bp, *cur, *path, *buf; + + /* If it's an absolute or relative path name, it's easy. */ + if (strchr(name, '/')) { + bp = (char *) name; + cur = path = buf = NULL; + goto retry; + } + + /* Get the path we're searching. */ + if (!(path = getenv("PATH"))) { +#ifdef HAVE_CONFSTR + ln = confstr(_CS_PATH, NULL, 0); + if ((cur = path = malloc(ln + 1)) != NULL) { + path[0] = ':'; + (void) confstr (_CS_PATH, path + 1, ln); + } +#else + if ((cur = path = malloc(1 + 1)) != NULL) { + path[0] = ':'; + path[1] = '\0'; + } +#endif + } else + cur = path = strdup(path); + + if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL) + goto done; + + while (cur != NULL) { + p = cur; + if ((cur = strchr(cur, ':')) != NULL) + *cur++ = '\0'; + + /* + * It's a SHELL path -- double, leading and trailing colons mean the current + * directory. + */ + if (!*p) { + p = "."; + lp = 1; + } else + lp = strlen(p); + ln = strlen(name); + + memcpy(buf, p, lp); + buf[lp] = '/'; + memcpy(buf + lp + 1, name, ln); + buf[lp + ln + 1] = '\0'; + + retry: + (void) execve(bp, argv, envp); + switch (errno) { + case EACCES: + eacces = 1; + break; + case ENOENT: + break; + case ENOEXEC: + { + register size_t cnt; + register char **ap; + + for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt) + ; + if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) { + memcpy(ap + 2, argv + 1, cnt * sizeof(char *)); + + ap[0] = "sh"; + ap[1] = bp; + (void) execve("/bin/sh", ap, envp); + free(ap); + } + goto done; + } + case ETXTBSY: + if (etxtbsy < 3) + (void) sleep(++etxtbsy); + goto retry; + default: + goto done; + } + } + if (eacces) + errno = EACCES; + else if (!errno) + errno = ENOENT; + done: + if (path) + free(path); + if (buf) + free(buf); + return (-1); +} + + +/* Copied verbatim from ghc/lib/std/cbits/system.c. */ +void pPrPr_disableITimers (void) +{ +# ifdef HAVE_SETITIMER + /* Reset the itimers in the child, so it doesn't get plagued + * by SIGVTALRM interrupts. + */ + struct timeval tv_null = { 0, 0 }; + struct itimerval itv; + itv.it_interval = tv_null; + itv.it_value = tv_null; + setitimer(ITIMER_REAL, &itv, NULL); + setitimer(ITIMER_VIRTUAL, &itv, NULL); + setitimer(ITIMER_PROF, &itv, NULL); +# endif +} diff --git a/include/HsUnix.h b/include/HsUnix.h new file mode 100644 index 0000000..46af25a --- /dev/null +++ b/include/HsUnix.h @@ -0,0 +1,32 @@ +/* ----------------------------------------------------------------------------- + * $Id: HsUnix.h,v 1.1 2002/09/12 16:38:22 simonmar Exp $ + * + * (c) The University of Glasgow 2002 + * + * Definitions for package `unix' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +#ifndef HSUNIX_H +#define HSUNIX_H + +#include "config.h" + +#ifdef HAVE_SYS_WAIT_H +#include <sys/wait.h> +#endif + +extern int execvpe(char *name, char **argv, char **envp); + +#ifndef INLINE +#define INLINE extern inline +#endif + +INLINE int __hsunix_wifexited (int stat) { return WIFEXITED(stat); } +INLINE int __hsunix_wexitstatus (int stat) { return WEXITSTATUS(stat); } +INLINE int __hsunix_wifsignaled (int stat) { return WIFSIGNALED(stat); } +INLINE int __hsunix_wtermsig (int stat) { return WTERMSIG(stat); } +INLINE int __hsunix_wifstopped (int stat) { return WIFSTOPPED(stat); } +INLINE int __hsunix_wstopsig (int stat) { return WSTOPSIG(stat); } + +#endif diff --git a/include/Makefile b/include/Makefile new file mode 100644 index 0000000..ed4eaae --- /dev/null +++ b/include/Makefile @@ -0,0 +1,9 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +H_FILES = $(wildcard *.h) + +includedir = $(libdir)/include +INSTALL_INCLUDES = $(H_FILES) + +include $(TOP)/mk/target.mk diff --git a/unix.conf.in b/unix.conf.in index 7b4c851..4d33322 100644 --- a/unix.conf.in +++ b/unix.conf.in @@ -11,12 +11,17 @@ Package { #ifdef INSTALLING library_dirs = [ "$libdir" ], #else - library_dirs = [ "$libdir/libraries/unix" ], + library_dirs = [ "$libdir/libraries/unix", + "$libdir/libraries/unix/cbits" ], #endif hs_libraries = [ "HSunix" ], - extra_libraries = [], + extra_libraries = [ "HSunix_cbits" ], +#ifdef INSTALLING include_dirs = [], - c_includes = [], +#else + include_dirs = [ "$libdir/libraries/unix/include" ], +#endif + c_includes = [ "HsUnix.h" ], package_deps = [ "base" ], extra_ghc_opts = [], extra_cc_opts = [], |