diff --git a/System/Posix/Directory.hsc b/System/Posix/Directory.hsc --- a/System/Posix/Directory.hsc +++ b/System/Posix/Directory.hsc @@ -39,14 +39,30 @@ import System.Posix.Types import Foreign import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif + -- | @createDirectory dir mode@ calls @mkdir@ to -- create a new directory, @dir@, with permissions based on -- @mode@. createDirectory :: FilePath -> FileMode -> IO () createDirectory name mode = - withCString name $ \s -> - throwErrnoPathIfMinus1_ "createDirectory" name (c_mkdir s mode) + withFilePath name $ \s -> + throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode) + -- POSIX doesn't allow mkdir() to return EINTR, but it does on + -- OS X (#5184), so we need the Retry variant here. foreign import ccall unsafe "mkdir" c_mkdir :: CString -> CMode -> IO CInt @@ -57,8 +73,8 @@ -- directory stream for @dir@. openDirStream :: FilePath -> IO DirStream openDirStream name = - withCString name $ \s -> do - dirp <- throwErrnoPathIfNull "openDirStream" name $ c_opendir s + withFilePath name $ \s -> do + dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s return (DirStream dirp) foreign import ccall unsafe "__hsunix_opendir" @@ -80,7 +96,7 @@ if (dEnt == nullPtr) then return [] else do - entry <- (d_name dEnt >>= peekCString) + entry <- (d_name dEnt >>= peekFilePath) c_freeDirEnt dEnt return entry else do errno <- getErrno @@ -115,7 +131,7 @@ -- the directory stream @dp@. closeDirStream :: DirStream -> IO () closeDirStream (DirStream dirp) = do - throwErrnoIfMinus1_ "closeDirStream" (c_closedir dirp) + throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp) foreign import ccall unsafe "closedir" c_closedir :: Ptr CDir -> IO CInt @@ -152,7 +168,7 @@ where go p bytes = do p' <- c_getcwd p (fromIntegral bytes) if p' /= nullPtr - then do s <- peekCString p' + then do s <- peekFilePath p' free p' return s else do errno <- getErrno @@ -173,7 +189,7 @@ changeWorkingDirectory :: FilePath -> IO () changeWorkingDirectory path = modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s) foreign import ccall unsafe "chdir" @@ -182,7 +198,7 @@ removeDirectory :: FilePath -> IO () removeDirectory path = modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) foreign import ccall unsafe "rmdir" @@ -190,7 +206,7 @@ changeWorkingDirectoryFd :: Fd -> IO () changeWorkingDirectoryFd (Fd fd) = - throwErrnoIfMinus1_ "changeWorkingDirectoryFd" (c_fchdir fd) + throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd) foreign import ccall unsafe "fchdir" c_fchdir :: CInt -> IO CInt diff --git a/System/Posix/DynamicLinker.hsc b/System/Posix/DynamicLinker.hsc --- a/System/Posix/DynamicLinker.hsc +++ b/System/Posix/DynamicLinker.hsc @@ -51,11 +51,17 @@ import Control.Exception ( bracket ) import Control.Monad ( liftM ) import Foreign.Ptr ( Ptr, nullPtr, FunPtr, nullFunPtr ) -import Foreign.C.String ( withCString, peekCString ) +import Foreign.C.String +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif -dlopen :: String -> [RTLDFlags] -> IO DL +dlopen :: FilePath -> [RTLDFlags] -> IO DL dlopen path flags = do - withCString path $ \ p -> do + withFilePath path $ \ p -> do liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags) dlclose :: DL -> IO () @@ -70,7 +76,7 @@ dlsym :: DL -> String -> IO (FunPtr a) dlsym source symbol = do - withCString symbol $ \ s -> do + withCAString symbol $ \ s -> do throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s withDL :: String -> [RTLDFlags] -> (DL -> IO a) -> IO a diff --git a/System/Posix/DynamicLinker/Module.hsc b/System/Posix/DynamicLinker/Module.hsc --- a/System/Posix/DynamicLinker/Module.hsc +++ b/System/Posix/DynamicLinker/Module.hsc @@ -58,8 +58,15 @@ import System.Posix.DynamicLinker import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else import Foreign.C.String ( withCString ) +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + -- abstract handle for dynamically loaded module (EXPORTED) -- newtype Module = Module (Ptr ()) @@ -72,7 +79,7 @@ moduleOpen :: String -> [RTLDFlags] -> IO Module moduleOpen file flags = do - modPtr <- withCString file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) + modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) if (modPtr == nullPtr) then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err)) else return $ Module modPtr diff --git a/System/Posix/Env.hsc b/System/Posix/Env.hsc --- a/System/Posix/Env.hsc +++ b/System/Posix/Env.hsc @@ -33,14 +33,28 @@ import Foreign.Storable import Control.Monad ( liftM ) import Data.Maybe ( fromMaybe ) +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif + -- |'getEnv' looks up a variable in the environment. getEnv :: String -> IO (Maybe String) getEnv name = do - litstring <- withCString name c_getenv + litstring <- withFilePath name c_getenv if litstring /= nullPtr - then liftM Just $ peekCString litstring + then liftM Just $ peekFilePath litstring else return Nothing -- |'getEnvDefault' is a wrapper around 'getEnv' where the @@ -55,12 +69,24 @@ getEnvironmentPrim :: IO [String] getEnvironmentPrim = do - c_environ <- peek c_environ_p + c_environ <- getCEnviron arr <- peekArray0 nullPtr c_environ - mapM peekCString arr + mapM peekFilePath arr +getCEnviron :: IO (Ptr CString) +#if darwin_HOST_OS +-- You should not access _environ directly on Darwin in a bundle/shared library. +-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html +getCEnviron = nsGetEnviron >>= peek + +foreign import ccall unsafe "_NSGetEnviron" + nsGetEnviron :: IO (Ptr (Ptr CString)) +#else +getCEnviron = peek c_environ_p + foreign import ccall unsafe "&environ" c_environ_p :: Ptr (Ptr CString) +#endif -- |'getEnvironment' retrieves the entire environment as a -- list of @(key,value)@ pairs. @@ -79,7 +105,7 @@ unsetEnv :: String -> IO () #ifdef HAVE_UNSETENV -unsetEnv name = withCString name $ \ s -> +unsetEnv name = withFilePath name $ \ s -> throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) foreign import ccall unsafe "__hsunix_unsetenv" @@ -92,7 +118,7 @@ -- and is equivalent to @setEnv(key,value,True{-overwrite-})@. putEnv :: String -> IO () -putEnv keyvalue = withCString keyvalue $ \s -> +putEnv keyvalue = withFilePath keyvalue $ \s -> throwErrnoIfMinus1_ "putenv" (c_putenv s) foreign import ccall unsafe "putenv" @@ -108,8 +134,8 @@ setEnv :: String -> String -> Bool {-overwrite-} -> IO () #ifdef HAVE_SETENV setEnv key value ovrwrt = do - withCString key $ \ keyP -> - withCString value $ \ valueP -> + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> throwErrnoIfMinus1_ "setenv" $ c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) diff --git a/System/Posix/Error.hs b/System/Posix/Error.hs --- a/System/Posix/Error.hs +++ b/System/Posix/Error.hs @@ -21,7 +21,8 @@ throwErrnoPathIfNullRetry, throwErrnoPathIfMinus1, throwErrnoPathIfMinus1_, - throwErrnoPathIfMinus1Retry + throwErrnoPathIfMinus1Retry, + throwErrnoPathIfMinus1Retry_ ) where import Foreign @@ -30,6 +31,10 @@ throwErrnoPathIfMinus1Retry :: Num a => String -> FilePath -> IO a -> IO a throwErrnoPathIfMinus1Retry loc path f = throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfMinus1Retry_ :: Num a => String -> FilePath -> IO a -> IO () +throwErrnoPathIfMinus1Retry_ loc path f = + void $ throwErrnoPathIfRetry (== -1) loc path f throwErrnoPathIfNullRetry :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a) throwErrnoPathIfNullRetry loc path f = diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -24,6 +24,8 @@ -- ----------------------------------------------------------------------------- +#include "HsUnix.h" + module System.Posix.Files ( -- * File modes -- FileMode exported by System.Posix.Types @@ -84,8 +86,6 @@ PathVar(..), getPathVar, getFdPathVar, ) where -#include "HsUnix.h" - import System.Posix.Error import System.Posix.Types import System.IO.Unsafe @@ -93,7 +93,27 @@ import System.Posix.Internals import Foreign hiding (unsafePerformIO) import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString + +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString + +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#endif + -- ----------------------------------------------------------------------------- -- POSIX file modes @@ -212,7 +232,7 @@ -- Note: calls @chmod@. setFileMode :: FilePath -> FileMode -> IO () setFileMode name m = - withCString name $ \s -> do + withFilePath name $ \s -> do throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -- | @setFdMode fd mode@ acts like 'setFileMode' but uses a file descriptor @@ -255,7 +275,7 @@ -- Note: calls @access@. fileExist :: FilePath -> IO Bool fileExist name = - withCString name $ \s -> do + withFilePath name $ \s -> do r <- c_access s (#const F_OK) if (r == 0) then return True @@ -266,7 +286,7 @@ access :: FilePath -> CMode -> IO Bool access name flags = - withCString name $ \s -> do + withFilePath name $ \s -> do r <- c_access s (fromIntegral flags) if (r == 0) then return True @@ -370,7 +390,7 @@ getFileStatus path = do fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) withForeignPtr fp $ \p -> - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "getFileStatus" path (c_stat s p) return (FileStatus fp) @@ -393,7 +413,7 @@ getSymbolicLinkStatus path = do fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) withForeignPtr fp $ \p -> - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) return (FileStatus fp) @@ -409,7 +429,7 @@ -- Note: calls @mkfifo@. createNamedPipe :: FilePath -> FileMode -> IO () createNamedPipe name mode = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode) -- | @createDevice path mode dev@ creates either a regular or a special file @@ -422,7 +442,7 @@ -- Note: calls @mknod@. createDevice :: FilePath -> FileMode -> DeviceID -> IO () createDevice path mode dev = - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev) foreign import ccall unsafe "__hsunix_mknod" @@ -437,8 +457,8 @@ -- Note: calls @link@. createLink :: FilePath -> FilePath -> IO () createLink name1 name2 = - withCString name1 $ \s1 -> - withCString name2 $ \s2 -> + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2) -- | @removeLink path@ removes the link named @path@. @@ -446,7 +466,7 @@ -- Note: calls @unlink@. removeLink :: FilePath -> IO () removeLink name = - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s) -- ----------------------------------------------------------------------------- @@ -461,8 +481,8 @@ -- Note: calls @symlink@. createSymbolicLink :: FilePath -> FilePath -> IO () createSymbolicLink file1 file2 = - withCString file1 $ \s1 -> - withCString file2 $ \s2 -> + withFilePath file1 $ \s1 -> + withFilePath file2 $ \s2 -> throwErrnoPathIfMinus1_ "createSymbolicLink" file1 (c_symlink s1 s2) foreign import ccall unsafe "symlink" @@ -483,10 +503,10 @@ readSymbolicLink :: FilePath -> IO FilePath readSymbolicLink file = allocaArray0 (#const PATH_MAX) $ \buf -> do - withCString file $ \s -> do + withFilePath file $ \s -> do len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ c_readlink s buf (#const PATH_MAX) - peekCStringLen (buf,fromIntegral len) + peekFilePathLen (buf,fromIntegral len) foreign import ccall unsafe "readlink" c_readlink :: CString -> CString -> CSize -> IO CInt @@ -499,8 +519,8 @@ -- Note: calls @rename@. rename :: FilePath -> FilePath -> IO () rename name1 name2 = - withCString name1 $ \s1 -> - withCString name2 $ \s2 -> + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2) foreign import ccall unsafe "rename" @@ -517,7 +537,7 @@ -- Note: calls @chown@. setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () setOwnerAndGroup name uid gid = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid) foreign import ccall unsafe "chown" @@ -541,7 +561,7 @@ -- Note: calls @lchown@. setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () setSymbolicLinkOwnerAndGroup name uid gid = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name (c_lchown s uid gid) @@ -558,7 +578,7 @@ -- Note: calls @utime@. setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () setFileTimes name atime mtime = do - withCString name $ \s -> + withFilePath name $ \s -> allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do (#poke struct utimbuf, actime) p atime (#poke struct utimbuf, modtime) p mtime @@ -570,7 +590,7 @@ -- Note: calls @utime@. touchFile :: FilePath -> IO () touchFile name = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) -- ----------------------------------------------------------------------------- @@ -582,7 +602,7 @@ -- Note: calls @truncate@. setFileSize :: FilePath -> FileOffset -> IO () setFileSize file off = - withCString file $ \s -> + withFilePath file $ \s -> throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off) foreign import ccall unsafe "truncate" @@ -672,7 +692,7 @@ -- Note: calls @pathconf@. getPathVar :: FilePath -> PathVar -> IO Limit getPathVar name v = do - withCString name $ \ nameP -> + withFilePath name $ \ nameP -> throwErrnoPathIfMinus1 "getPathVar" name $ c_pathconf nameP (pathVarConst v) diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc --- a/System/Posix/IO.hsc +++ b/System/Posix/IO.hsc @@ -94,6 +94,13 @@ import qualified Hugs.IO (handleToFd, openFd) #endif +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + #include "HsUnix.h" -- ----------------------------------------------------------------------------- @@ -178,7 +185,7 @@ -> IO Fd openFd name how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag nonBlockFlag truncateFlag) = do - withCString name $ \s -> do + withFilePath name $ \s -> do fd <- throwErrnoPathIfMinus1Retry "openFd" name (c_open s all_flags mode_w) return (Fd fd) where @@ -259,7 +266,7 @@ -- state as a result. flushWriteBuffer h_ FD.release fd - return (Handle__{haType=ClosedHandle,..}, Fd (fromIntegral (FD.fdFD fd))) + return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd)) fdToHandle fd = FD.fdToHandle (fromIntegral fd) @@ -424,8 +431,8 @@ -- ----------------------------------------------------------------------------- -- fd{Read,Write} --- | Read data from an 'Fd' and convert it to a 'String'. Throws an --- exception if this is an invalid descriptor, or EOF has been +-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding. +-- Throws an exception if this is an invalid descriptor, or EOF has been -- reached. fdRead :: Fd -> ByteCount -- ^How many bytes to read @@ -434,7 +441,7 @@ fdRead fd nbytes = do allocaBytes (fromIntegral nbytes) $ \ buf -> do rc <- fdReadBuf fd buf nbytes - case fromIntegral rc of + case rc of 0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF") n -> do s <- peekCStringLen (castPtr buf, fromIntegral n) @@ -450,18 +457,16 @@ fdReadBuf fd buf nbytes = fmap fromIntegral $ throwErrnoIfMinus1Retry "fdReadBuf" $ - c_safe_read (fromIntegral fd) (castPtr buf) (fromIntegral nbytes) + c_safe_read (fromIntegral fd) (castPtr buf) nbytes foreign import ccall safe "read" c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize --- | Write a 'String' to an 'Fd' (no character conversion is done, --- the least-significant 8 bits of each character are written). +-- | Write a 'String' to an 'Fd' using the locale encoding. fdWrite :: Fd -> String -> IO ByteCount fdWrite fd str = - withCStringLen str $ \ (buf,len) -> do - rc <- fdWriteBuf fd (castPtr buf) (fromIntegral len) - return (fromIntegral rc) + withCStringLen str $ \ (buf,len) -> + fdWriteBuf fd (castPtr buf) (fromIntegral len) -- | Write data from memory to an 'Fd'. This is exactly equivalent -- to the POSIX @write@ function. @@ -472,7 +477,7 @@ fdWriteBuf fd buf len = fmap fromIntegral $ throwErrnoIfMinus1Retry "fdWriteBuf" $ - c_safe_write (fromIntegral fd) (castPtr buf) (fromIntegral len) + c_safe_write (fromIntegral fd) (castPtr buf) len foreign import ccall safe "write" c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc --- a/System/Posix/Process.hsc +++ b/System/Posix/Process.hsc @@ -29,12 +29,13 @@ -- ** Process environment getProcessID, getParentProcessID, - getProcessGroupID, -- ** Process groups - createProcessGroup, + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, joinProcessGroup, - setProcessGroupID, + setProcessGroupIDOf, -- ** Sessions createSession, @@ -58,12 +59,16 @@ getAnyProcessStatus, getGroupProcessStatus, + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + ) where #include "HsUnix.h" import Foreign.C.Error -import Foreign.C.String ( CString, withCString ) +import Foreign.C.String import Foreign.C.Types ( CInt, CClock ) import Foreign.Marshal.Alloc ( alloca, allocaBytes ) import Foreign.Marshal.Array ( withArray0 ) @@ -80,6 +85,13 @@ import GHC.TopHandler ( runIO ) #endif +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + #ifdef __HUGS__ {-# CFILES cbits/HsUnix.c #-} #endif @@ -111,11 +123,33 @@ foreign import ccall unsafe "getpgrp" c_getpgrp :: IO CPid --- | @'createProcessGroup' pid@ calls @setpgid@ to make +-- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the +-- 'ProcessGroupID' for process @pid@. +getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID +getProcessGroupIDOf pid = + throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid) + +foreign import ccall unsafe "getpgid" + c_getpgid :: CPid -> IO CPid + +{- + To be added in the future, after the deprecation period for the + existing createProcessGroup has elapsed: + +-- | 'createProcessGroup' calls @setpgid(0,0)@ to make +-- the current process a new process group leader. +createProcessGroup :: IO ProcessGroupID +createProcessGroup = do + throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0) + pgid <- getProcessGroupID + return pgid +-} + +-- | @'createProcessGroupFor' pid@ calls @setpgid@ to make -- process @pid@ a new process group leader. -createProcessGroup :: ProcessID -> IO ProcessGroupID -createProcessGroup pid = do - throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) +createProcessGroupFor :: ProcessID -> IO ProcessGroupID +createProcessGroupFor pid = do + throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0) return pid -- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the @@ -124,12 +158,23 @@ joinProcessGroup pgid = throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid) --- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the --- 'ProcessGroupID' for process @pid@ to @pgid@. -setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () -setProcessGroupID pid pgid = - throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) +{- + To be added in the future, after the deprecation period for the + existing setProcessGroupID has elapsed: +-- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the +-- 'ProcessGroupID' of the current process to @pgid@. +setProcessGroupID :: ProcessGroupID -> IO () +setProcessGroupID pgid = + throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid) +-} + +-- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the +-- 'ProcessGroupIDOf' for process @pid@ to @pgid@. +setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO () +setProcessGroupIDOf pid pgid = + throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid) + foreign import ccall unsafe "setpgid" c_setpgid :: CPid -> CPid -> IO CInt @@ -256,7 +301,7 @@ stable <- newStablePtr (runIO action) pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable) freeStablePtr stable - return $ fromIntegral pid + return pid foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid #endif /* __GLASGOW_HASKELL__ */ @@ -275,8 +320,8 @@ -> Maybe [(String, String)] -- ^ Environment -> IO a executeFile path search args Nothing = do - withCString path $ \s -> - withMany withCString (path:args) $ \cstrs -> + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> withArray0 nullPtr cstrs $ \arr -> do pPrPr_disableITimers if search @@ -285,11 +330,11 @@ return undefined -- never reached executeFile path search args (Just env) = do - withCString path $ \s -> - withMany withCString (path:args) $ \cstrs -> + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> withArray0 nullPtr cstrs $ \arg_arr -> let env' = map (\ (name, val) -> name ++ ('=' : val)) env in - withMany withCString env' $ \cenv -> + withMany withFilePath env' $ \cenv -> withArray0 nullPtr cenv $ \env_arr -> do pPrPr_disableITimers if search @@ -387,5 +432,29 @@ foreign import ccall unsafe "exit" c_exit :: CInt -> IO () + +-- ----------------------------------------------------------------------------- +-- Deprecated or subject to change + +{-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use createProcessGroupFor instead." #-} +-- | @'createProcessGroup' pid@ calls @setpgid@ to make +-- process @pid@ a new process group leader. +-- This function is currently deprecated, +-- and might be changed to making the current +-- process a new process group leader in future versions. +createProcessGroup :: ProcessID -> IO ProcessGroupID +createProcessGroup pid = do + throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) + return pid + +{-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use setProcessGroupIdOf instead." #-} +-- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the +-- 'ProcessGroupID' for process @pid@ to @pgid@. +-- This function is currently deprecated, +-- and might be changed to setting the 'ProcessGroupID' +-- for the current process in future versions. +setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () +setProcessGroupID pid pgid = + throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) -- ----------------------------------------------------------------------------- diff --git a/System/Posix/Process/Internals.hs b/System/Posix/Process/Internals.hs --- a/System/Posix/Process/Internals.hs +++ b/System/Posix/Process/Internals.hs @@ -34,12 +34,12 @@ if c_WIFSIGNALED wstat /= 0 then do let termsig = c_WTERMSIG wstat - return (Terminated (fromIntegral termsig)) + return (Terminated termsig) else do if c_WIFSTOPPED wstat /= 0 then do let stopsig = c_WSTOPSIG wstat - return (Stopped (fromIntegral stopsig)) + return (Stopped stopsig) else do ioError (mkIOError illegalOperationErrorType "waitStatus" Nothing Nothing) diff --git a/System/Posix/Signals.hsc b/System/Posix/Signals.hsc --- a/System/Posix/Signals.hsc +++ b/System/Posix/Signals.hsc @@ -276,7 +276,7 @@ -- with interrupt signal @int@. signalProcess :: Signal -> ProcessID -> IO () signalProcess sig pid - = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig) + = throwErrnoIfMinus1_ "signalProcess" (c_kill pid sig) foreign import ccall unsafe "kill" c_kill :: CPid -> CInt -> IO CInt @@ -286,7 +286,7 @@ -- all processes in group @pgid@ with interrupt signal @int@. signalProcessGroup :: Signal -> ProcessGroupID -> IO () signalProcessGroup sig pgid - = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig) + = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg pgid sig) foreign import ccall unsafe "killpg" c_killpg :: CPid -> CInt -> IO CInt diff --git a/System/Posix/Temp.hsc b/System/Posix/Temp.hsc --- a/System/Posix/Temp.hsc +++ b/System/Posix/Temp.hsc @@ -32,6 +32,21 @@ import System.Posix.Types import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif + -- |'mkstemp' - make a unique filename and open it for -- reading\/writing (only safe on GHC & Hugs). -- The returned 'FilePath' is the (possibly relative) path of @@ -39,9 +54,9 @@ mkstemp :: String -> IO (FilePath, Handle) mkstemp template = do #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) - withCString template $ \ ptr -> do + withFilePath template $ \ ptr -> do fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) - name <- peekCString ptr + name <- peekFilePath ptr h <- fdToHandle (Fd fd) return (name, h) #else @@ -54,9 +69,9 @@ mktemp :: String -> IO String mktemp template = do - withCString template $ \ ptr -> do + withFilePath template $ \ ptr -> do ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) - peekCString ptr + peekFilePath ptr foreign import ccall unsafe "mktemp" c_mktemp :: CString -> IO CString diff --git a/System/Posix/User.hsc b/System/Posix/User.hsc --- a/System/Posix/User.hsc +++ b/System/Posix/User.hsc @@ -131,7 +131,7 @@ getLoginName = do -- ToDo: use getlogin_r str <- throwErrnoIfNull "getLoginName" c_getlogin - peekCString str + peekCAString str foreign import ccall unsafe "getlogin" c_getlogin :: IO CString @@ -225,7 +225,7 @@ getGroupEntryForName name = do allocaBytes (#const sizeof(struct group)) $ \pgr -> alloca $ \ ppgr -> - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do throwErrorIfNonZero_ "getGroupEntryForName" $ doubleAllocWhile isERANGE grBufSize $ \s b -> c_getgrnam_r pstr pgr b (fromIntegral s) ppgr @@ -287,11 +287,11 @@ unpackGroupEntry :: Ptr CGroup -> IO GroupEntry unpackGroupEntry ptr = do - name <- (#peek struct group, gr_name) ptr >>= peekCString - passwd <- (#peek struct group, gr_passwd) ptr >>= peekCString + name <- (#peek struct group, gr_name) ptr >>= peekCAString + passwd <- (#peek struct group, gr_passwd) ptr >>= peekCAString gid <- (#peek struct group, gr_gid) ptr mem <- (#peek struct group, gr_mem) ptr - members <- peekArray0 nullPtr mem >>= mapM peekCString + members <- peekArray0 nullPtr mem >>= mapM peekCAString return (GroupEntry name passwd gid members) -- ----------------------------------------------------------------------------- @@ -359,7 +359,7 @@ getUserEntryForName name = do allocaBytes (#const sizeof(struct passwd)) $ \ppw -> alloca $ \ pppw -> - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do throwErrorIfNonZero_ "getUserEntryForName" $ doubleAllocWhile isERANGE pwBufSize $ \s b -> c_getpwnam_r pstr ppw b (fromIntegral s) pppw @@ -377,7 +377,7 @@ -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt #elif HAVE_GETPWNAM getUserEntryForName name = do - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do withMVar lock $ \_ -> do ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr unpackUserEntry ppw @@ -446,13 +446,13 @@ unpackUserEntry :: Ptr CPasswd -> IO UserEntry unpackUserEntry ptr = do - name <- (#peek struct passwd, pw_name) ptr >>= peekCString - passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCString + name <- (#peek struct passwd, pw_name) ptr >>= peekCAString + passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCAString uid <- (#peek struct passwd, pw_uid) ptr gid <- (#peek struct passwd, pw_gid) ptr - gecos <- (#peek struct passwd, pw_gecos) ptr >>= peekCString - dir <- (#peek struct passwd, pw_dir) ptr >>= peekCString - shell <- (#peek struct passwd, pw_shell) ptr >>= peekCString + gecos <- (#peek struct passwd, pw_gecos) ptr >>= peekCAString + dir <- (#peek struct passwd, pw_dir) ptr >>= peekCAString + shell <- (#peek struct passwd, pw_shell) ptr >>= peekCAString return (UserEntry name passwd uid gid gecos dir shell) -- Used when calling re-entrant system calls that signal their 'errno' @@ -462,7 +462,7 @@ rc <- act if (rc == 0) then return () - else ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else ioError (errnoToIOError loc (Errno rc) Nothing Nothing) -- Used when a function returns NULL to indicate either an error or -- EOF, depending on whether the global errno is nonzero. diff --git a/configure b/configure --- a/configure +++ b/configure @@ -3799,7 +3799,7 @@ done -for ac_header in libutil.h pty.h utmp.h +for ac_header in bsd/libutil.h libutil.h pty.h utmp.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -23,7 +23,7 @@ AC_CHECK_HEADERS([dirent.h fcntl.h grp.h limits.h pwd.h signal.h string.h]) AC_CHECK_HEADERS([sys/resource.h sys/stat.h sys/times.h sys/time.h]) AC_CHECK_HEADERS([sys/utsname.h sys/wait.h]) -AC_CHECK_HEADERS([libutil.h pty.h utmp.h]) +AC_CHECK_HEADERS([bsd/libutil.h libutil.h pty.h utmp.h]) AC_CHECK_HEADERS([termios.h time.h unistd.h utime.h]) AC_CHECK_FUNCS([getgrgid_r getgrnam_r getpwnam_r getpwuid_r getpwnam getpwuid]) diff --git a/include/HsUnix.h b/include/HsUnix.h --- a/include/HsUnix.h +++ b/include/HsUnix.h @@ -75,7 +75,9 @@ #include #endif -#ifdef HAVE_LIBUTIL_H +#if defined(HAVE_BSD_LIBUTIL_H) +#include +#elif defined(HAVE_LIBUTIL_H) #include #endif #ifdef HAVE_PTY_H diff --git a/include/HsUnixConfig.h b/include/HsUnixConfig.h --- a/include/HsUnixConfig.h +++ b/include/HsUnixConfig.h @@ -94,6 +94,9 @@ /* The value of SIG_UNBLOCK. */ #define CONST_SIG_UNBLOCK 1 +/* Define to 1 if you have the header file. */ +/* #undef HAVE_BSD_LIBUTIL_H */ + /* Define if we have /dev/ptc. */ /* #undef HAVE_DEV_PTC */ diff --git a/include/HsUnixConfig.h.in b/include/HsUnixConfig.h.in --- a/include/HsUnixConfig.h.in +++ b/include/HsUnixConfig.h.in @@ -93,6 +93,9 @@ /* The value of SIG_UNBLOCK. */ #undef CONST_SIG_UNBLOCK +/* Define to 1 if you have the header file. */ +#undef HAVE_BSD_LIBUTIL_H + /* Define if we have /dev/ptc. */ #undef HAVE_DEV_PTC diff --git a/unix.cabal b/unix.cabal --- a/unix.cabal +++ b/unix.cabal @@ -1,5 +1,5 @@ name: unix -version: 2.4.2.0 +version: 2.5.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -47,8 +47,10 @@ System.Posix.Signals.Exts System.Posix.Semaphore System.Posix.SharedMem - build-depends: base >= 4.2 && < 4.4 - extensions: CPP, ForeignFunctionInterface, EmptyDataDecls + build-depends: base >= 4.2 && < 4.5 + extensions: CPP, ForeignFunctionInterface, EmptyDataDecls + if impl(ghc >= 7.1) + extensions: NondecreasingIndentation include-dirs: include includes: HsUnix.h execvpe.h install-includes: @@ -56,6 +58,6 @@ c-sources: cbits/HsUnix.c cbits/execvpe.c cbits/dirUtils.c source-repository head - type: darcs - location: http://darcs.haskell.org/packages/unix/ + type: git + location: http://darcs.haskell.org/packages/unix.git/