diff --git a/.travis.yml b/.travis.yml index ab0743e..b6a586d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -68,6 +68,7 @@ install: - cabal install --installdir=$HOME/.cabal/bin doctest script: + - (cd unix && autoreconf -fi) - cabal build --enable-tests all - cabal run spec - ./hpath/run-doctests.sh diff --git a/cabal.project b/cabal.project index 48842ae..10ce572 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,7 @@ packages: ./hpath ./hpath-filepath ./hpath-io ./hpath-posix + ./unix package hpath-io ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 diff --git a/hpath-posix/src/System/Posix/RawFilePath/Directory/Traversals.hs b/hpath-posix/src/System/Posix/RawFilePath/Directory/Traversals.hs index d5c5bbc..146a4b1 100644 --- a/hpath-posix/src/System/Posix/RawFilePath/Directory/Traversals.hs +++ b/hpath-posix/src/System/Posix/RawFilePath/Directory/Traversals.hs @@ -30,8 +30,6 @@ module System.Posix.RawFilePath.Directory.Traversals ( -- lower-level stuff , readDirEnt -, packDirStream -, unpackDirStream , fdOpendir , realpath @@ -52,11 +50,11 @@ import Control.Exception import qualified Data.ByteString.Char8 as BS import System.Posix.ByteString.FilePath import System.Posix.Directory.ByteString as PosixBS +import System.Posix.Directory.Common import System.Posix.Files.ByteString import System.IO.Unsafe import "unix" System.Posix.IO.ByteString (closeFd) -import Unsafe.Coerce (unsafeCoerce) import Foreign.C.Error import Foreign.C.String import Foreign.C.Types @@ -148,18 +146,6 @@ actOnDirContents pathRelToTop b f = ---------------------------------------------------------- -- dodgy stuff -type CDir = () -type CDirent = () - --- Posix doesn't export DirStream, so to re-use that type we need to use --- unsafeCoerce. It's just a newtype, so this is a legitimate usage. --- ugly trick. -unpackDirStream :: DirStream -> Ptr CDir -unpackDirStream = unsafeCoerce - -packDirStream :: Ptr CDir -> DirStream -packDirStream = unsafeCoerce - -- the __hscore_* functions are defined in the unix package. We can import them and let -- the linker figure it out. foreign import ccall unsafe "__hscore_readdir" @@ -178,14 +164,14 @@ foreign import ccall "realpath" c_realpath :: CString -> CString -> IO CString foreign import ccall unsafe "fdopendir" - c_fdopendir :: Posix.Fd -> IO (Ptr ()) + c_fdopendir :: Posix.Fd -> IO (Ptr CDir) ---------------------------------------------------------- -- less dodgy but still lower-level readDirEnt :: DirStream -> IO (DirType, RawFilePath) -readDirEnt (unpackDirStream -> dirp) = +readDirEnt (DirStream dirp) = alloca $ \ptr_dEnt -> loop ptr_dEnt where loop ptr_dEnt = do @@ -228,7 +214,7 @@ getDirectoryContents path = -- |Binding to @fdopendir(3)@. fdOpendir :: Posix.Fd -> IO DirStream fdOpendir fd = - packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) + DirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) -- |Like `getDirectoryContents` except for a file descriptor. diff --git a/unix/LICENSE b/unix/LICENSE new file mode 100644 index 0000000..4ec14bf --- /dev/null +++ b/unix/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- 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. + +- Neither 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 UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. diff --git a/unix/README.md b/unix/README.md new file mode 100644 index 0000000..918cfc1 --- /dev/null +++ b/unix/README.md @@ -0,0 +1,15 @@ +The `unix` Package [![Hackage](https://img.shields.io/hackage/v/unix.svg)](https://hackage.haskell.org/package/unix) [![Build Status](https://travis-ci.org/haskell/unix.svg)](https://travis-ci.org/haskell/unix) +================== + +See [`unix` on Hackage](http://hackage.haskell.org/package/unix) for +more information. + +Installing from Git +------------------- + +To build this package using Cabal directly from Git, you must run +`autoreconf -i` before the usual Cabal build steps (`cabal +{configure,build,install}`). The program `autoreconf` is part of +[GNU autoconf](http://www.gnu.org/software/autoconf/). There is no +need to run the `configure` script: `cabal configure` will do this for +you. diff --git a/unix/Setup.hs b/unix/Setup.hs new file mode 100644 index 0000000..54f57d6 --- /dev/null +++ b/unix/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks autoconfUserHooks diff --git a/unix/System/Posix.hs b/unix/System/Posix.hs new file mode 100644 index 0000000..c31bb05 --- /dev/null +++ b/unix/System/Posix.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix +-- 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) +-- +-- support +-- +----------------------------------------------------------------------------- + +module System.Posix ( + module System.Posix.Types, + module System.Posix.Signals, + module System.Posix.Directory, + module System.Posix.Files, + module System.Posix.Unistd, + module System.Posix.IO, + module System.Posix.Env, + module System.Posix.Process, + module System.Posix.Temp, + module System.Posix.Terminal, + module System.Posix.Time, + module System.Posix.User, + module System.Posix.Resource, + module System.Posix.Semaphore, + module System.Posix.SharedMem, + module System.Posix.DynamicLinker, +-- XXX 'Module' type clashes with GHC +-- module System.Posix.DynamicLinker.Module + ) where + +import System.Posix.Types +import System.Posix.Signals +import System.Posix.Directory +import System.Posix.Files +import System.Posix.Unistd +import System.Posix.Process +import System.Posix.IO +import System.Posix.Env +import System.Posix.Temp +import System.Posix.Terminal +import System.Posix.Time +import System.Posix.User +import System.Posix.Resource +import System.Posix.Semaphore +import System.Posix.SharedMem +-- XXX: bad planning, we have two constructors called "Default" +import System.Posix.DynamicLinker hiding (Default) +--import System.Posix.DynamicLinker.Module + +{- TODO + +Here we detail our support for the IEEE Std 1003.1-2001 standard. For +each header file defined by the standard, we categorise its +functionality as + + - "supported" + + Full equivalent functionality is provided by the specified Haskell + module. + + - "unsupported" (functionality not provided by a Haskell module) + + The functionality is not currently provided. + + - "to be supported" + + Currently unsupported, but support is planned for the future. + +Exceptions are listed where appropriate. + +Interfaces supported +-------------------- + +unix package: + +dirent.h System.Posix.Directory +dlfcn.h System.Posix.DynamicLinker +errno.h Foreign.C.Error +fcntl.h System.Posix.IO +signal.h System.Posix.Signals +sys/stat.h System.Posix.Files +sys/times.h System.Posix.Process +sys/types.h System.Posix.Types (with exceptions...) +sys/utsname.h System.Posix.Unistd +sys/wait.h System.Posix.Process +termios.h System.Posix.Terminal (check exceptions) +unistd.h System.Posix.* +utime.h System.Posix.Files +pwd.h System.Posix.User +grp.h System.Posix.User +stdlib.h: System.Posix.Env (getenv()/setenv()/unsetenv()) + System.Posix.Temp (mkstemp()) +sys/resource.h: System.Posix.Resource (get/setrlimit() only) + +regex-posix package: + +regex.h Text.Regex.Posix + +network package: + +arpa/inet.h +net/if.h +netinet/in.h +netinet/tcp.h +sys/socket.h +sys/un.h + +To be supported +--------------- + +limits.h (pathconf()/fpathconf() already done) +poll.h +sys/resource.h (getrusage(): use instead of times() for getProcessTimes?) +sys/select.h +sys/statvfs.h (?) +sys/time.h (but maybe not the itimer?) +time.h (System.Posix.Time) +stdio.h (popen only: System.Posix.IO) +sys/mman.h + +Unsupported interfaces +---------------------- + +aio.h +assert.h +complex.h +cpio.h +ctype.h +fenv.h +float.h +fmtmsg.h +fnmatch.h +ftw.h +glob.h +iconv.h +inttypes.h +iso646.h +langinfo.h +libgen.h +locale.h (see System.Locale) +math.h +monetary.h +mqueue.h +ndbm.h +netdb.h +nl_types.h +pthread.h +sched.h +search.h +semaphore.h +setjmp.h +spawn.h +stdarg.h +stdbool.h +stddef.h +stdint.h +stdio.h except: popen() +stdlib.h except: exit(): System.Posix.Process + free()/malloc(): Foreign.Marshal.Alloc + getenv()/setenv(): ?? System.Environment + rand() etc.: System.Random +string.h +strings.h +stropts.h +sys/ipc.h +sys/msg.h +sys/sem.h +sys/shm.h +sys/timeb.h +sys/uio.h +syslog.h +tar.h +tgmath.h +trace.h +ucontext.h +ulimit.h +utmpx.h +wchar.h +wctype.h +wordexp.h + +-} diff --git a/unix/System/Posix/ByteString.hs b/unix/System/Posix/ByteString.hs new file mode 100644 index 0000000..7fea0ef --- /dev/null +++ b/unix/System/Posix/ByteString.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.ByteString +-- 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) +-- +-- +-- support with 'ByteString' file paths and environment strings. +-- +-- This module exports exactly the same API as "System.Posix", except +-- that all file paths and environment strings are represented by +-- 'ByteString' instead of 'String'. The "System.Posix" API +-- implicitly translates all file paths and environment strings using +-- the locale encoding, whereas this version of the API does no +-- encoding or decoding and works directly in terms of raw bytes. +-- +-- Note that if you do need to interpret file paths or environment +-- strings as text, then some Unicode encoding or decoding should be +-- applied first. +-- +----------------------------------------------------------------------------- + +module System.Posix.ByteString ( + System.Posix.ByteString.FilePath.RawFilePath, + module System.Posix.Types, + module System.Posix.Signals, + module System.Posix.Directory.ByteString, + module System.Posix.Files.ByteString, + module System.Posix.Unistd, + module System.Posix.IO.ByteString, + module System.Posix.Env.ByteString, + module System.Posix.Process.ByteString, + module System.Posix.Temp.ByteString, + module System.Posix.Terminal.ByteString, + module System.Posix.Time, + module System.Posix.User, + module System.Posix.Resource, + module System.Posix.Semaphore, + module System.Posix.SharedMem, + module System.Posix.DynamicLinker.ByteString, +-- XXX 'Module' type clashes with GHC +-- module System.Posix.DynamicLinker.Module.ByteString + ) where + +import System.Posix.ByteString.FilePath +import System.Posix.Types +import System.Posix.Signals +import System.Posix.Directory.ByteString +import System.Posix.Files.ByteString +import System.Posix.Unistd +import System.Posix.Process.ByteString +import System.Posix.IO.ByteString +import System.Posix.Env.ByteString +import System.Posix.Temp.ByteString +import System.Posix.Terminal.ByteString +import System.Posix.Time +import System.Posix.User +import System.Posix.Resource +import System.Posix.Semaphore +import System.Posix.SharedMem +-- XXX: bad planning, we have two constructors called "Default" +import System.Posix.DynamicLinker.ByteString hiding (Default) +--import System.Posix.DynamicLinker.Module.ByteString diff --git a/unix/System/Posix/ByteString/FilePath.hsc b/unix/System/Posix/ByteString/FilePath.hsc new file mode 100644 index 0000000..b6768fc --- /dev/null +++ b/unix/System/Posix/ByteString/FilePath.hsc @@ -0,0 +1,127 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.ByteString.FilePath +-- 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) +-- +-- Internal stuff: support for ByteString FilePaths +-- +----------------------------------------------------------------------------- + +module System.Posix.ByteString.FilePath ( + RawFilePath, withFilePath, peekFilePath, peekFilePathLen, + throwErrnoPathIfMinus1Retry, + throwErrnoPathIfMinus1Retry_, + throwErrnoPathIfNullRetry, + throwErrnoPathIfRetry, + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ + ) where + +import Foreign hiding ( void ) +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import Control.Monad +import Data.ByteString +import Data.ByteString.Char8 as BC +import Prelude hiding (FilePath) + +-- | A literal POSIX file path +type RawFilePath = ByteString + +withFilePath :: RawFilePath -> (CString -> IO a) -> IO a +withFilePath = useAsCString + +peekFilePath :: CString -> IO RawFilePath +peekFilePath = packCString + +peekFilePathLen :: CStringLen -> IO RawFilePath +peekFilePathLen = packCStringLen + + +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) + => String -> RawFilePath -> IO a -> IO a +throwErrnoPathIfMinus1Retry loc path f = do + throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a) + => String -> RawFilePath -> IO a -> IO () +throwErrnoPathIfMinus1Retry_ loc path f = + void $ throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfNullRetry :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNullRetry loc path f = + throwErrnoPathIfRetry (== nullPtr) loc path f + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a +throwErrnoPathIfRetry pr loc rpath f = + do + res <- f + if pr res + then do + err <- getErrno + if err == eINTR + then throwErrnoPathIfRetry pr loc rpath f + else throwErrnoPath loc rpath + else return res + +-- | as 'throwErrno', but exceptions include the given path when appropriate. +-- +throwErrnoPath :: String -> RawFilePath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just (BC.unpack path))) + +-- | as 'throwErrnoIf', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a +throwErrnoPathIf cond loc path f = + do + res <- f + if cond res then throwErrnoPath loc path else return res + +-- | as 'throwErrnoIf_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf_ :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO () +throwErrnoPathIf_ cond loc path f = void $ throwErrnoPathIf cond loc path f + +-- | as 'throwErrnoIfNull', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfNull :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNull = throwErrnoPathIf (== nullPtr) + +-- | as 'throwErrnoIfMinus1', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO a +throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1) + +-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO () +throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) diff --git a/unix/System/Posix/Directory.hsc b/unix/System/Posix/Directory.hsc new file mode 100644 index 0000000..10dcbb4 --- /dev/null +++ b/unix/System/Posix/Directory.hsc @@ -0,0 +1,164 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE NondecreasingIndentation #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Directory +-- 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) +-- +-- String-based POSIX directory support +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +-- hack copied from System.Posix.Files +#if !defined(PATH_MAX) +# define PATH_MAX 4096 +#endif + +module System.Posix.Directory ( + -- * Creating and removing directories + createDirectory, removeDirectory, + + -- * Reading directories + DirStream, + openDirStream, + readDirStream, + rewindDirStream, + closeDirStream, + DirStreamOffset, +#ifdef HAVE_TELLDIR + tellDirStream, +#endif +#ifdef HAVE_SEEKDIR + seekDirStream, +#endif + + -- * The working dirctory + getWorkingDirectory, + changeWorkingDirectory, + changeWorkingDirectoryFd, + ) where + +import System.IO.Error +import System.Posix.Error +import System.Posix.Types +import Foreign +import Foreign.C + +import System.Posix.Directory.Common +import System.Posix.Internals (withFilePath, peekFilePath) + +-- | @createDirectory dir mode@ calls @mkdir@ to +-- create a new directory, @dir@, with permissions based on +-- @mode@. +createDirectory :: FilePath -> FileMode -> IO () +createDirectory name 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 + +-- | @openDirStream dir@ calls @opendir@ to obtain a +-- directory stream for @dir@. +openDirStream :: FilePath -> IO DirStream +openDirStream name = + withFilePath name $ \s -> do + dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s + return (DirStream dirp) + +foreign import capi unsafe "HsUnix.h opendir" + c_opendir :: CString -> IO (Ptr CDir) + +-- | @readDirStream dp@ calls @readdir@ to obtain the +-- next directory entry (@struct dirent@) for the open directory +-- stream @dp@, and returns the @d_name@ member of that +-- structure. +readDirStream :: DirStream -> IO FilePath +readDirStream (DirStream dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if (r == 0) + then do dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return [] + else do + entry <- (d_name dEnt >>= peekFilePath) + c_freeDirEnt dEnt + return entry + else do errno <- getErrno + if (errno == eINTR) then loop ptr_dEnt else do + let (Errno eo) = errno + if (eo == 0) + then return [] + else throwErrno "readDirStream" + +-- traversing directories +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + d_name :: Ptr CDirent -> IO CString + + +-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name +-- of the current working directory. +getWorkingDirectory :: IO FilePath +getWorkingDirectory = go (#const PATH_MAX) + where + go bytes = do + r <- allocaBytes bytes $ \buf -> do + buf' <- c_getcwd buf (fromIntegral bytes) + if buf' /= nullPtr + then do s <- peekFilePath buf + return (Just s) + else do errno <- getErrno + if errno == eRANGE + -- we use Nothing to indicate that we should + -- try again with a bigger buffer + then return Nothing + else throwErrno "getWorkingDirectory" + maybe (go (2 * bytes)) return r + +foreign import ccall unsafe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) + +-- | @changeWorkingDirectory dir@ calls @chdir@ to change +-- the current working directory to @dir@. +changeWorkingDirectory :: FilePath -> IO () +changeWorkingDirectory path = + modifyIOError (`ioeSetFileName` path) $ + withFilePath path $ \s -> + throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s) + +foreign import ccall unsafe "chdir" + c_chdir :: CString -> IO CInt + +removeDirectory :: FilePath -> IO () +removeDirectory path = + modifyIOError (`ioeSetFileName` path) $ + withFilePath path $ \s -> + throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) + +foreign import ccall unsafe "rmdir" + c_rmdir :: CString -> IO CInt diff --git a/unix/System/Posix/Directory/ByteString.hsc b/unix/System/Posix/Directory/ByteString.hsc new file mode 100644 index 0000000..e0393ad --- /dev/null +++ b/unix/System/Posix/Directory/ByteString.hsc @@ -0,0 +1,165 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE NondecreasingIndentation #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Directory.ByteString +-- 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) +-- +-- String-based POSIX directory support +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +-- hack copied from System.Posix.Files +#if !defined(PATH_MAX) +# define PATH_MAX 4096 +#endif + +module System.Posix.Directory.ByteString ( + -- * Creating and removing directories + createDirectory, removeDirectory, + + -- * Reading directories + DirStream, + openDirStream, + readDirStream, + rewindDirStream, + closeDirStream, + DirStreamOffset, +#ifdef HAVE_TELLDIR + tellDirStream, +#endif +#ifdef HAVE_SEEKDIR + seekDirStream, +#endif + + -- * The working directory + getWorkingDirectory, + changeWorkingDirectory, + changeWorkingDirectoryFd, + ) where + +import System.IO.Error +import System.Posix.Types +import Foreign +import Foreign.C + +import Data.ByteString.Char8 as BC + +import System.Posix.Directory.Common +import System.Posix.ByteString.FilePath + +-- | @createDirectory dir mode@ calls @mkdir@ to +-- create a new directory, @dir@, with permissions based on +-- @mode@. +createDirectory :: RawFilePath -> FileMode -> IO () +createDirectory name 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 + +-- | @openDirStream dir@ calls @opendir@ to obtain a +-- directory stream for @dir@. +openDirStream :: RawFilePath -> IO DirStream +openDirStream name = + withFilePath name $ \s -> do + dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s + return (DirStream dirp) + +foreign import capi unsafe "HsUnix.h opendir" + c_opendir :: CString -> IO (Ptr CDir) + +-- | @readDirStream dp@ calls @readdir@ to obtain the +-- next directory entry (@struct dirent@) for the open directory +-- stream @dp@, and returns the @d_name@ member of that +-- structure. +readDirStream :: DirStream -> IO RawFilePath +readDirStream (DirStream dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if (r == 0) + then do dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return BC.empty + else do + entry <- (d_name dEnt >>= peekFilePath) + c_freeDirEnt dEnt + return entry + else do errno <- getErrno + if (errno == eINTR) then loop ptr_dEnt else do + let (Errno eo) = errno + if (eo == 0) + then return BC.empty + else throwErrno "readDirStream" + +-- traversing directories +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + d_name :: Ptr CDirent -> IO CString + + +-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name +-- of the current working directory. +getWorkingDirectory :: IO RawFilePath +getWorkingDirectory = go (#const PATH_MAX) + where + go bytes = do + r <- allocaBytes bytes $ \buf -> do + buf' <- c_getcwd buf (fromIntegral bytes) + if buf' /= nullPtr + then do s <- peekFilePath buf + return (Just s) + else do errno <- getErrno + if errno == eRANGE + -- we use Nothing to indicate that we should + -- try again with a bigger buffer + then return Nothing + else throwErrno "getWorkingDirectory" + maybe (go (2 * bytes)) return r + +foreign import ccall unsafe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) + +-- | @changeWorkingDirectory dir@ calls @chdir@ to change +-- the current working directory to @dir@. +changeWorkingDirectory :: RawFilePath -> IO () +changeWorkingDirectory path = + modifyIOError (`ioeSetFileName` (BC.unpack path)) $ + withFilePath path $ \s -> + throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s) + +foreign import ccall unsafe "chdir" + c_chdir :: CString -> IO CInt + +removeDirectory :: RawFilePath -> IO () +removeDirectory path = + modifyIOError (`ioeSetFileName` BC.unpack path) $ + withFilePath path $ \s -> + throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) + +foreign import ccall unsafe "rmdir" + c_rmdir :: CString -> IO CInt diff --git a/unix/System/Posix/Directory/Common.hsc b/unix/System/Posix/Directory/Common.hsc new file mode 100644 index 0000000..aba20af --- /dev/null +++ b/unix/System/Posix/Directory/Common.hsc @@ -0,0 +1,88 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Directory.Common +-- 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 directory support +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Directory.Common ( + DirStream(..), CDir, CDirent, DirStreamOffset(..), + rewindDirStream, + closeDirStream, +#ifdef HAVE_SEEKDIR + seekDirStream, +#endif +#ifdef HAVE_TELLDIR + tellDirStream, +#endif + changeWorkingDirectoryFd, + ) where + +import System.Posix.Types +import Foreign +import Foreign.C + +newtype DirStream = DirStream (Ptr CDir) + +data {-# CTYPE "DIR" #-} CDir +data {-# CTYPE "struct dirent" #-} CDirent + +-- | @rewindDirStream dp@ calls @rewinddir@ to reposition +-- the directory stream @dp@ at the beginning of the directory. +rewindDirStream :: DirStream -> IO () +rewindDirStream (DirStream dirp) = c_rewinddir dirp + +foreign import ccall unsafe "rewinddir" + c_rewinddir :: Ptr CDir -> IO () + +-- | @closeDirStream dp@ calls @closedir@ to close +-- the directory stream @dp@. +closeDirStream :: DirStream -> IO () +closeDirStream (DirStream dirp) = do + throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp) + +foreign import ccall unsafe "closedir" + c_closedir :: Ptr CDir -> IO CInt + +newtype DirStreamOffset = DirStreamOffset COff + +#ifdef HAVE_SEEKDIR +seekDirStream :: DirStream -> DirStreamOffset -> IO () +seekDirStream (DirStream dirp) (DirStreamOffset off) = + c_seekdir dirp (fromIntegral off) -- TODO: check for CLong/COff overflow + +foreign import ccall unsafe "seekdir" + c_seekdir :: Ptr CDir -> CLong -> IO () +#endif + +#ifdef HAVE_TELLDIR +tellDirStream :: DirStream -> IO DirStreamOffset +tellDirStream (DirStream dirp) = do + off <- c_telldir dirp + return (DirStreamOffset (fromIntegral off)) -- TODO: check for overflow + +foreign import ccall unsafe "telldir" + c_telldir :: Ptr CDir -> IO CLong +#endif + +changeWorkingDirectoryFd :: Fd -> IO () +changeWorkingDirectoryFd (Fd fd) = + throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd) + +foreign import ccall unsafe "fchdir" + c_fchdir :: CInt -> IO CInt diff --git a/unix/System/Posix/DynamicLinker.hsc b/unix/System/Posix/DynamicLinker.hsc new file mode 100644 index 0000000..b484f5d --- /dev/null +++ b/unix/System/Posix/DynamicLinker.hsc @@ -0,0 +1,72 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- Dynamic linker support through dlopen() +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker ( + + module System.Posix.DynamicLinker.Prim, + dlopen, + dlsym, + dlerror, + dlclose, + withDL, withDL_, + undl, + ) + +-- Usage: +-- ****** +-- +-- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) +-- offering a function +-- @char \* mogrify (char\*,int)@ +-- and invoke @str = mogrify("test",1)@: +-- +-- +-- type Fun = CString -> Int -> IO CString +-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun +-- +-- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do +-- funptr <- dlsym mod "mogrify" +-- let fun = fun__ funptr +-- withCString "test" \$ \\ str -> do +-- strptr <- fun str 1 +-- strstr <- peekCString strptr +-- ... +-- + +where + +import System.Posix.DynamicLinker.Common +import System.Posix.DynamicLinker.Prim + +#include "HsUnix.h" + +import Control.Exception ( bracket ) +import Control.Monad ( liftM ) +import Foreign +import System.Posix.Internals ( withFilePath ) + +dlopen :: FilePath -> [RTLDFlags] -> IO DL +dlopen path flags = do + withFilePath path $ \ p -> do + liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags) + +withDL :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a +withDL file flags f = bracket (dlopen file flags) (dlclose) f + +withDL_ :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO () +withDL_ file flags f = withDL file flags f >> return () diff --git a/unix/System/Posix/DynamicLinker/ByteString.hsc b/unix/System/Posix/DynamicLinker/ByteString.hsc new file mode 100644 index 0000000..1693fed --- /dev/null +++ b/unix/System/Posix/DynamicLinker/ByteString.hsc @@ -0,0 +1,73 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker.ByteString +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- Dynamic linker support through dlopen() +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker.ByteString ( + + module System.Posix.DynamicLinker.Prim, + dlopen, + dlsym, + dlerror, + dlclose, + withDL, withDL_, + undl, + ) + +-- Usage: +-- ****** +-- +-- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) +-- offering a function +-- @char \* mogrify (char\*,int)@ +-- and invoke @str = mogrify("test",1)@: +-- +-- +-- type Fun = CString -> Int -> IO CString +-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun +-- +-- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do +-- funptr <- dlsym mod "mogrify" +-- let fun = fun__ funptr +-- withCString "test" \$ \\ str -> do +-- strptr <- fun str 1 +-- strstr <- peekCString strptr +-- ... +-- + +where + +import System.Posix.DynamicLinker.Common +import System.Posix.DynamicLinker.Prim + +#include "HsUnix.h" + +import Control.Exception ( bracket ) +import Control.Monad ( liftM ) +import Foreign +import System.Posix.ByteString.FilePath + +dlopen :: RawFilePath -> [RTLDFlags] -> IO DL +dlopen path flags = do + withFilePath path $ \ p -> do + liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags) + +withDL :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a +withDL file flags f = bracket (dlopen file flags) (dlclose) f + +withDL_ :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO () +withDL_ file flags f = withDL file flags f >> return () diff --git a/unix/System/Posix/DynamicLinker/Common.hsc b/unix/System/Posix/DynamicLinker/Common.hsc new file mode 100644 index 0000000..32bfccc --- /dev/null +++ b/unix/System/Posix/DynamicLinker/Common.hsc @@ -0,0 +1,92 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker.Common +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- Dynamic linker support through dlopen() +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker.Common ( + + module System.Posix.DynamicLinker.Prim, + dlsym, + dlerror, + dlclose, + undl, + throwDLErrorIf, + Module(..) + ) + +-- Usage: +-- ****** +-- +-- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) +-- offering a function +-- @char \* mogrify (char\*,int)@ +-- and invoke @str = mogrify("test",1)@: +-- +-- +-- type Fun = CString -> Int -> IO CString +-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun +-- +-- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do +-- funptr <- dlsym mod "mogrify" +-- let fun = fun__ funptr +-- withCString "test" \$ \\ str -> do +-- strptr <- fun str 1 +-- strstr <- peekCString strptr +-- ... +-- + +where + +#include "HsUnix.h" + +import System.Posix.DynamicLinker.Prim +import Foreign +import Foreign.C + +dlclose :: DL -> IO () +dlclose (DLHandle h) = throwDLErrorIf_ "dlclose" (/= 0) $ c_dlclose h +dlclose h = error $ "dlclose: invalid argument" ++ (show h) + +dlerror :: IO String +dlerror = c_dlerror >>= peekCString + +-- |'dlsym' returns the address binding of the symbol described in @symbol@, +-- as it occurs in the shared object identified by @source@. + +dlsym :: DL -> String -> IO (FunPtr a) +dlsym source symbol = do + withCAString symbol $ \ s -> do + throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s + +-- |'undl' obtains the raw handle. You mustn't do something like +-- @withDL mod flags $ liftM undl >>= \ p -> use p@ + +undl :: DL -> Ptr () +undl = packDL + +throwDLErrorIf :: String -> (a -> Bool) -> IO a -> IO a +throwDLErrorIf s p f = do + r <- f + if (p r) + then dlerror >>= \ err -> ioError (userError ( s ++ ": " ++ err)) + else return r + +throwDLErrorIf_ :: String -> (a -> Bool) -> IO a -> IO () +throwDLErrorIf_ s p f = throwDLErrorIf s p f >> return () + +-- abstract handle for dynamically loaded module (EXPORTED) +-- +newtype Module = Module (Ptr ()) diff --git a/unix/System/Posix/DynamicLinker/Module.hsc b/unix/System/Posix/DynamicLinker/Module.hsc new file mode 100644 index 0000000..eb4938b --- /dev/null +++ b/unix/System/Posix/DynamicLinker/Module.hsc @@ -0,0 +1,121 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker.Module +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- DLOpen support, old API +-- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs +-- I left the API more or less the same, mostly the flags are different. +-- +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker.Module ( + +-- Usage: +-- ****** +-- +-- Let's assume you want to open a local shared library 'foo' (./libfoo.so) +-- offering a function +-- char * mogrify (char*,int) +-- and invoke str = mogrify("test",1): +-- +-- type Fun = CString -> Int -> IO CString +-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun +-- +-- withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do +-- funptr <- moduleSymbol mod "mogrify" +-- let fun = fun__ funptr +-- withCString "test" $ \ str -> do +-- strptr <- fun str 1 +-- strstr <- peekCString strptr +-- ... + + Module + , moduleOpen -- :: String -> ModuleFlags -> IO Module + , moduleSymbol -- :: Source -> String -> IO (FunPtr a) + , moduleClose -- :: Module -> IO Bool + , moduleError -- :: IO String + , withModule -- :: Maybe String + -- -> String + -- -> [ModuleFlags ] + -- -> (Module -> IO a) + -- -> IO a + , withModule_ -- :: Maybe String + -- -> String + -- -> [ModuleFlags] + -- -> (Module -> IO a) + -- -> IO () + ) +where + +#include "HsUnix.h" + +import System.Posix.DynamicLinker +import System.Posix.DynamicLinker.Common +import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +import System.Posix.Internals ( withFilePath ) + +unModule :: Module -> (Ptr ()) +unModule (Module adr) = adr + +-- Opens a module (EXPORTED) +-- + +moduleOpen :: String -> [RTLDFlags] -> IO Module +moduleOpen file flags = do + modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) + if (modPtr == nullPtr) + then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err)) + else return $ Module modPtr + +-- Gets a symbol pointer from a module (EXPORTED) +-- +moduleSymbol :: Module -> String -> IO (FunPtr a) +moduleSymbol file sym = dlsym (DLHandle (unModule file)) sym + +-- Closes a module (EXPORTED) +-- +moduleClose :: Module -> IO () +moduleClose file = dlclose (DLHandle (unModule file)) + +-- Gets a string describing the last module error (EXPORTED) +-- +moduleError :: IO String +moduleError = dlerror + + +-- Convenience function, cares for module open- & closing +-- additionally returns status of `moduleClose' (EXPORTED) +-- +withModule :: Maybe String + -> String + -> [RTLDFlags] + -> (Module -> IO a) + -> IO a +withModule mdir file flags p = do + let modPath = case mdir of + Nothing -> file + Just dir -> dir ++ if ((head (reverse dir)) == '/') + then file + else ('/':file) + modu <- moduleOpen modPath flags + result <- p modu + moduleClose modu + return result + +withModule_ :: Maybe String + -> String + -> [RTLDFlags] + -> (Module -> IO a) + -> IO () +withModule_ dir file flags p = withModule dir file flags p >>= \ _ -> return () diff --git a/unix/System/Posix/DynamicLinker/Module/ByteString.hsc b/unix/System/Posix/DynamicLinker/Module/ByteString.hsc new file mode 100644 index 0000000..3a902bc --- /dev/null +++ b/unix/System/Posix/DynamicLinker/Module/ByteString.hsc @@ -0,0 +1,79 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker.Module.ByteString +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- DLOpen support, old API +-- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs +-- I left the API more or less the same, mostly the flags are different. +-- +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker.Module.ByteString ( + +-- Usage: +-- ****** +-- +-- Let's assume you want to open a local shared library 'foo' (./libfoo.so) +-- offering a function +-- char * mogrify (char*,int) +-- and invoke str = mogrify("test",1): +-- +-- type Fun = CString -> Int -> IO CString +-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun +-- +-- withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do +-- funptr <- moduleSymbol mod "mogrify" +-- let fun = fun__ funptr +-- withCString "test" $ \ str -> do +-- strptr <- fun str 1 +-- strstr <- peekCString strptr +-- ... + + Module + , moduleOpen -- :: String -> ModuleFlags -> IO Module + , moduleSymbol -- :: Source -> String -> IO (FunPtr a) + , moduleClose -- :: Module -> IO Bool + , moduleError -- :: IO String + , withModule -- :: Maybe String + -- -> String + -- -> [ModuleFlags ] + -- -> (Module -> IO a) + -- -> IO a + , withModule_ -- :: Maybe String + -- -> String + -- -> [ModuleFlags] + -- -> (Module -> IO a) + -- -> IO () + ) +where + +#include "HsUnix.h" + +import System.Posix.DynamicLinker.Module hiding (moduleOpen) +import System.Posix.DynamicLinker.Prim +import System.Posix.DynamicLinker.Common + +import Foreign +import System.Posix.ByteString.FilePath + +-- Opens a module (EXPORTED) +-- + +moduleOpen :: RawFilePath -> [RTLDFlags] -> IO Module +moduleOpen file flags = do + 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/unix/System/Posix/DynamicLinker/Prim.hsc b/unix/System/Posix/DynamicLinker/Prim.hsc new file mode 100644 index 0000000..f014bb6 --- /dev/null +++ b/unix/System/Posix/DynamicLinker/Prim.hsc @@ -0,0 +1,123 @@ +{-# LANGUAGE Trustworthy #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# OPTIONS_GHC -fno-warn-trustworthy-safe #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.DynamicLinker.Prim +-- Copyright : (c) Volker Stolz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- @dlopen(3)@ and friends +-- Derived from @GModule.chs@ by M.Weber & M.Chakravarty which is part of c2hs. +-- I left the API more or less the same, mostly the flags are different. +-- +----------------------------------------------------------------------------- + +module System.Posix.DynamicLinker.Prim ( + -- * low level API + c_dlopen, + c_dlsym, + c_dlerror, + c_dlclose, + -- dlAddr, -- XXX NYI + haveRtldNext, + haveRtldLocal, + packRTLDFlags, + RTLDFlags(..), + packDL, + DL(..), + ) + +where + +#include "HsUnix.h" + +import Data.Bits ( (.|.) ) +import Foreign.Ptr ( Ptr, FunPtr, nullPtr ) +import Foreign.C.Types +import Foreign.C.String ( CString ) + + +-- |On some hosts (e.g. SuSe and Ubuntu Linux) @RTLD_NEXT@ (and +-- @RTLD_DEFAULT@) are not visible without setting the macro +-- @_GNU_SOURCE@. Since we don\'t want to define this macro, you can use +-- the function 'haveRtldNext' to check wether the flag `Next` is +-- available. Ideally, this will be optimized by the compiler so that it +-- should be as efficient as an @#ifdef@. +-- +-- If you fail to test the flag and use it although it is undefined, +-- 'packDL' will throw an error. + +haveRtldNext :: Bool + +#ifdef HAVE_RTLDNEXT +haveRtldNext = True +foreign import ccall unsafe "__hsunix_rtldNext" rtldNext :: Ptr a +#else /* HAVE_RTLDNEXT */ +haveRtldNext = False +#endif /* HAVE_RTLDNEXT */ + +#ifdef HAVE_RTLDDEFAULT +foreign import ccall unsafe "__hsunix_rtldDefault" rtldDefault :: Ptr a +#endif /* HAVE_RTLDDEFAULT */ + +haveRtldLocal :: Bool +haveRtldLocal = True +{-# DEPRECATED haveRtldLocal "defaults to True" #-} + + +-- |Flags for 'System.Posix.DynamicLinker.dlopen'. + +data RTLDFlags + = RTLD_LAZY + | RTLD_NOW + | RTLD_GLOBAL + | RTLD_LOCAL + deriving (Show, Read) + +foreign import ccall unsafe "dlopen" c_dlopen :: CString -> CInt -> IO (Ptr ()) +foreign import ccall unsafe "dlsym" c_dlsym :: Ptr () -> CString -> IO (FunPtr a) +foreign import ccall unsafe "dlerror" c_dlerror :: IO CString +foreign import ccall unsafe "dlclose" c_dlclose :: (Ptr ()) -> IO CInt + +packRTLDFlags :: [RTLDFlags] -> CInt +packRTLDFlags flags = foldl (\ s f -> (packRTLDFlag f) .|. s) 0 flags + +packRTLDFlag :: RTLDFlags -> CInt +packRTLDFlag RTLD_LAZY = #const RTLD_LAZY +packRTLDFlag RTLD_NOW = #const RTLD_NOW +packRTLDFlag RTLD_GLOBAL = #const RTLD_GLOBAL +packRTLDFlag RTLD_LOCAL = #const RTLD_LOCAL + + +-- |Flags for 'System.Posix.DynamicLinker.dlsym'. Notice that 'Next' +-- might not be available on your particular platform! Use +-- 'haveRtldNext'. +-- +-- If 'RTLD_DEFAULT' is not defined on your platform, 'packDL' 'Default' +-- reduces to 'nullPtr'. + +data DL = Null | Next | Default | DLHandle (Ptr ()) deriving (Show) + +packDL :: DL -> Ptr () +packDL Null = nullPtr + +#ifdef HAVE_RTLDNEXT +packDL Next = rtldNext +#else +packDL Next = error "RTLD_NEXT not available" +#endif + +#ifdef HAVE_RTLDDEFAULT +packDL Default = rtldDefault +#else +packDL Default = nullPtr +#endif + +packDL (DLHandle h) = h diff --git a/unix/System/Posix/Env.hsc b/unix/System/Posix/Env.hsc new file mode 100644 index 0000000..2e052ad --- /dev/null +++ b/unix/System/Posix/Env.hsc @@ -0,0 +1,205 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Env +-- 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 environment support +-- +----------------------------------------------------------------------------- + +module System.Posix.Env ( + getEnv + , getEnvDefault + , getEnvironmentPrim + , getEnvironment + , setEnvironment + , putEnv + , setEnv + , unsetEnv + , clearEnv +) where + +#include "HsUnix.h" + +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Control.Monad +import Data.Maybe (fromMaybe) +import System.Posix.Internals + +#if !MIN_VERSION_base(4,7,0) +-- needed for backported local 'newFilePath' binding in 'putEnv' +import GHC.IO.Encoding (getFileSystemEncoding) +import qualified GHC.Foreign as GHC (newCString) +#endif + +-- |'getEnv' looks up a variable in the environment. + +getEnv :: + String {- ^ variable name -} -> + IO (Maybe String) {- ^ variable value -} +getEnv name = do + litstring <- withFilePath name c_getenv + if litstring /= nullPtr + then liftM Just $ peekFilePath litstring + else return Nothing + +-- |'getEnvDefault' is a wrapper around 'getEnv' where the +-- programmer can specify a fallback if the variable is not found +-- in the environment. + +getEnvDefault :: + String {- ^ variable name -} -> + String {- ^ fallback value -} -> + IO String {- ^ variable value or fallback value -} +getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name) + +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO CString + +getEnvironmentPrim :: IO [String] +getEnvironmentPrim = do + c_environ <- getCEnviron + -- environ can be NULL + if c_environ == nullPtr + then return [] + else do + arr <- peekArray0 nullPtr c_environ + mapM peekFilePath arr + +getCEnviron :: IO (Ptr CString) +#if HAVE__NSGETENVIRON +-- You should not access @char **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. + +getEnvironment :: IO [(String,String)] {- ^ @[(key,value)]@ -} +getEnvironment = do + env <- getEnvironmentPrim + return $ map (dropEq.(break ((==) '='))) env + where + dropEq (x,'=':ys) = (x,ys) + dropEq (x,_) = error $ "getEnvironment: insane variable " ++ x + +-- |'setEnvironment' resets the entire environment to the given list of +-- @(key,value)@ pairs. + +setEnvironment :: + [(String,String)] {- ^ @[(key,value)]@ -} -> + IO () +setEnvironment env = do + clearEnv + forM_ env $ \(key,value) -> + setEnv key value True {-overwrite-} + +-- |The 'unsetEnv' function deletes all instances of the variable name +-- from the environment. + +unsetEnv :: String {- ^ variable name -} -> IO () +#if HAVE_UNSETENV +# if !UNSETENV_RETURNS_VOID +unsetEnv name = withFilePath name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + +-- POSIX.1-2001 compliant unsetenv(3) +foreign import capi unsafe "HsUnix.h unsetenv" + c_unsetenv :: CString -> IO CInt +# else +unsetEnv name = withFilePath name c_unsetenv + +-- pre-POSIX unsetenv(3) returning @void@ +foreign import capi unsafe "HsUnix.h unsetenv" + c_unsetenv :: CString -> IO () +# endif +#else +unsetEnv name = putEnv (name ++ "=") +#endif + +-- |'putEnv' function takes an argument of the form @name=value@ +-- and is equivalent to @setEnv(key,value,True{-overwrite-})@. + +putEnv :: String {- ^ "key=value" -} -> IO () +putEnv keyvalue = do s <- newFilePath keyvalue + -- Do not free `s` after calling putenv. + -- According to SUSv2, the string passed to putenv + -- becomes part of the environment. #7342 + throwErrnoIfMinus1_ "putenv" (c_putenv s) +#if !MIN_VERSION_base(4,7,0) + where + newFilePath :: FilePath -> IO CString + newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp +#endif + +foreign import ccall unsafe "putenv" + c_putenv :: CString -> IO CInt + +{- |The 'setEnv' function inserts or resets the environment variable name in + the current environment list. If the variable @name@ does not exist in the + list, it is inserted with the given value. If the variable does exist, + the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is + not reset, otherwise it is reset to the given value. +-} + +setEnv :: + String {- ^ variable name -} -> + String {- ^ variable value -} -> + Bool {- ^ overwrite -} -> + IO () +#ifdef HAVE_SETENV +setEnv key value ovrwrt = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#else +setEnv key value True = putEnv (key++"="++value) +setEnv key value False = do + res <- getEnv key + case res of + Just _ -> return () + Nothing -> putEnv (key++"="++value) +#endif + +-- |The 'clearEnv' function clears the environment of all name-value pairs. +clearEnv :: IO () +#if HAVE_CLEARENV +clearEnv = void c_clearenv + +foreign import ccall unsafe "clearenv" + c_clearenv :: IO Int +#else +-- Fallback to 'environ[0] = NULL'. +clearEnv = do + c_environ <- getCEnviron + unless (c_environ == nullPtr) $ + poke c_environ nullPtr +#endif diff --git a/unix/System/Posix/Env/ByteString.hsc b/unix/System/Posix/Env/ByteString.hsc new file mode 100644 index 0000000..3ce867b --- /dev/null +++ b/unix/System/Posix/Env/ByteString.hsc @@ -0,0 +1,184 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE Trustworthy #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# OPTIONS_GHC -fno-warn-trustworthy-safe #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Env.ByteString +-- 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 environment support +-- +----------------------------------------------------------------------------- + +module System.Posix.Env.ByteString ( + -- * Environment Variables + getEnv + , getEnvDefault + , getEnvironmentPrim + , getEnvironment + , putEnv + , setEnv + , unsetEnv + + -- * Program arguments + , getArgs +) where + +#include "HsUnix.h" + +import Foreign +import Foreign.C +import Control.Monad ( liftM ) +import Data.Maybe ( fromMaybe ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.ByteString (ByteString) + +-- |'getEnv' looks up a variable in the environment. + +getEnv :: + ByteString {- ^ variable name -} -> + IO (Maybe ByteString) {- ^ variable value -} +getEnv name = do + litstring <- B.useAsCString name c_getenv + if litstring /= nullPtr + then liftM Just $ B.packCString litstring + else return Nothing + +-- |'getEnvDefault' is a wrapper around 'getEnv' where the +-- programmer can specify a fallback if the variable is not found +-- in the environment. + +getEnvDefault :: + ByteString {- ^ variable name -} -> + ByteString {- ^ fallback value -} -> + IO ByteString {- ^ variable value or fallback value -} +getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name) + +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO CString + +getEnvironmentPrim :: IO [ByteString] +getEnvironmentPrim = do + c_environ <- getCEnviron + arr <- peekArray0 nullPtr c_environ + mapM B.packCString arr + +getCEnviron :: IO (Ptr CString) +#if HAVE__NSGETENVIRON +-- You should not access @char **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. + +getEnvironment :: IO [(ByteString,ByteString)] {- ^ @[(key,value)]@ -} +getEnvironment = do + env <- getEnvironmentPrim + return $ map (dropEq.(BC.break ((==) '='))) env + where + dropEq (x,y) + | BC.head y == '=' = (x,B.tail y) + | otherwise = error $ "getEnvironment: insane variable " ++ BC.unpack x + +-- |The 'unsetEnv' function deletes all instances of the variable name +-- from the environment. + +unsetEnv :: ByteString {- ^ variable name -} -> IO () +#if HAVE_UNSETENV +# if !UNSETENV_RETURNS_VOID +unsetEnv name = B.useAsCString name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + +-- POSIX.1-2001 compliant unsetenv(3) +foreign import capi unsafe "HsUnix.h unsetenv" + c_unsetenv :: CString -> IO CInt +# else +unsetEnv name = B.useAsCString name c_unsetenv + +-- pre-POSIX unsetenv(3) returning @void@ +foreign import capi unsafe "HsUnix.h unsetenv" + c_unsetenv :: CString -> IO () +# endif +#else +unsetEnv name = putEnv (name ++ "=") +#endif + +-- |'putEnv' function takes an argument of the form @name=value@ +-- and is equivalent to @setEnv(key,value,True{-overwrite-})@. + +putEnv :: ByteString {- ^ "key=value" -} -> IO () +putEnv keyvalue = B.useAsCString keyvalue $ \s -> + throwErrnoIfMinus1_ "putenv" (c_putenv s) + +foreign import ccall unsafe "putenv" + c_putenv :: CString -> IO CInt + +{- |The 'setEnv' function inserts or resets the environment variable name in + the current environment list. If the variable @name@ does not exist in the + list, it is inserted with the given value. If the variable does exist, + the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is + not reset, otherwise it is reset to the given value. +-} + +setEnv :: + ByteString {- ^ variable name -} -> + ByteString {- ^ variable value -} -> + Bool {- ^ overwrite -} -> + IO () +#ifdef HAVE_SETENV +setEnv key value ovrwrt = do + B.useAsCString key $ \ keyP -> + B.useAsCString value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#else +setEnv key value True = putEnv (key++"="++value) +setEnv key value False = do + res <- getEnv key + case res of + Just _ -> return () + Nothing -> putEnv (key++"="++value) +#endif + +-- | Computation 'getArgs' returns a list of the program's command +-- line arguments (not including the program name), as 'ByteString's. +-- +-- Unlike 'System.Environment.getArgs', this function does no Unicode +-- decoding of the arguments; you get the exact bytes that were passed +-- to the program by the OS. To interpret the arguments as text, some +-- Unicode decoding should be applied. +-- +getArgs :: IO [ByteString] +getArgs = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getProgArgv p_argc p_argv + p <- fromIntegral `liftM` peek p_argc + argv <- peek p_argv + peekArray (p - 1) (advancePtr argv 1) >>= mapM B.packCString + +foreign import ccall unsafe "getProgArgv" + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () diff --git a/unix/System/Posix/Error.hs b/unix/System/Posix/Error.hs new file mode 100644 index 0000000..9d2ac70 --- /dev/null +++ b/unix/System/Posix/Error.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Error +-- 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 error support +-- +----------------------------------------------------------------------------- + +module System.Posix.Error ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfRetry, + throwErrnoPathIfNull, + throwErrnoPathIfNullRetry, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_, + throwErrnoPathIfMinus1Retry, + throwErrnoPathIfMinus1Retry_ + ) where + +import Foreign hiding (void) +import Foreign.C +import Control.Monad + +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) + => String -> FilePath -> IO a -> IO a +throwErrnoPathIfMinus1Retry loc path f = + throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfMinus1Retry_ :: (Eq a, 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 = + throwErrnoPathIfRetry (== nullPtr) loc path f + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> FilePath -> IO a -> IO a +throwErrnoPathIfRetry pr loc path f = + do + res <- f + if pr res + then do + err <- getErrno + if err == eINTR + then throwErrnoPathIfRetry pr loc path f + else throwErrnoPath loc path + else return res + diff --git a/unix/System/Posix/Fcntl.hsc b/unix/System/Posix/Fcntl.hsc new file mode 100644 index 0000000..c78f361 --- /dev/null +++ b/unix/System/Posix/Fcntl.hsc @@ -0,0 +1,104 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Fcntl +-- Copyright : (c) The University of Glasgow 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX file control support +-- +-- @since 2.7.1.0 +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Fcntl ( + -- * File allocation + Advice(..), fileAdvise, + fileAllocate, + ) where + +#if HAVE_POSIX_FALLOCATE || HAVE_POSIX_FADVISE +import Foreign.C +#endif +import System.Posix.Types + +#if !HAVE_POSIX_FALLOCATE +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- ----------------------------------------------------------------------------- +-- File control + +-- | Advice parameter for 'fileAdvise' operation. +-- +-- For more details, see documentation of @posix_fadvise(2)@. +-- +-- @since 2.7.1.0 +data Advice + = AdviceNormal + | AdviceRandom + | AdviceSequential + | AdviceWillNeed + | AdviceDontNeed + | AdviceNoReuse + deriving Eq + +-- | Performs @posix_fadvise(2)@ operation on file-descriptor. +-- +-- If platform does not provide @posix_fadvise(2)@ 'fileAdvise' +-- becomes a no-op. +-- +-- (use @#if HAVE_POSIX_FADVISE@ CPP guard to detect availability) +-- +-- @since 2.7.1.0 +fileAdvise :: Fd -> FileOffset -> FileOffset -> Advice -> IO () +#if HAVE_POSIX_FADVISE +fileAdvise fd off len adv = do + throwErrnoIfMinus1_ "fileAdvise" (c_posix_fadvise (fromIntegral fd) (fromIntegral off) (fromIntegral len) (packAdvice adv)) + +foreign import capi safe "fcntl.h posix_fadvise" + c_posix_fadvise :: CInt -> COff -> COff -> CInt -> IO CInt + +packAdvice :: Advice -> CInt +packAdvice AdviceNormal = (#const POSIX_FADV_NORMAL) +packAdvice AdviceRandom = (#const POSIX_FADV_RANDOM) +packAdvice AdviceSequential = (#const POSIX_FADV_SEQUENTIAL) +packAdvice AdviceWillNeed = (#const POSIX_FADV_WILLNEED) +packAdvice AdviceDontNeed = (#const POSIX_FADV_DONTNEED) +packAdvice AdviceNoReuse = (#const POSIX_FADV_NOREUSE) +#else +fileAdvise _ _ _ _ = return () +#endif + +-- | Performs @posix_fallocate(2)@ operation on file-descriptor. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @posix_fallocate(2)@. +-- +-- (use @#if HAVE_POSIX_FALLOCATE@ CPP guard to detect availability). +-- +-- @since 2.7.1.0 +fileAllocate :: Fd -> FileOffset -> FileOffset -> IO () +#if HAVE_POSIX_FALLOCATE +fileAllocate fd off len = do + throwErrnoIfMinus1_ "fileAllocate" (c_posix_fallocate (fromIntegral fd) (fromIntegral off) (fromIntegral len)) + +foreign import capi safe "fcntl.h posix_fallocate" + c_posix_fallocate :: CInt -> COff -> COff -> IO CInt +#else +{-# WARNING fileAllocate + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_POSIX_FALLOCATE@)" #-} +fileAllocate _ _ _ = ioError (ioeSetLocation unsupportedOperation + "fileAllocate") +#endif diff --git a/unix/System/Posix/Files.hsc b/unix/System/Posix/Files.hsc new file mode 100644 index 0000000..749f5da --- /dev/null +++ b/unix/System/Posix/Files.hsc @@ -0,0 +1,448 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Files +-- 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) +-- +-- Functions defined by the POSIX standards for manipulating and querying the +-- file system. Names of underlying POSIX functions are indicated whenever +-- possible. A more complete documentation of the POSIX functions together +-- with a more detailed description of different error conditions are usually +-- available in the system's manual pages or from +-- (free registration required). +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Files ( + -- * File modes + -- FileMode exported by System.Posix.Types + unionFileModes, intersectFileModes, + nullFileMode, + ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes, + groupReadMode, groupWriteMode, groupExecuteMode, groupModes, + otherReadMode, otherWriteMode, otherExecuteMode, otherModes, + setUserIDMode, setGroupIDMode, + stdFileMode, accessModes, + fileTypeModes, + blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode, + directoryMode, symbolicLinkMode, socketMode, + + -- ** Setting file modes + setFileMode, setFdMode, setFileCreationMask, + + -- ** Checking file existence and permissions + fileAccess, fileExist, + + -- * File status + FileStatus, + -- ** Obtaining file status + getFileStatus, getFdStatus, getSymbolicLinkStatus, + -- ** Querying file status + deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup, + specialDeviceID, fileSize, accessTime, modificationTime, + statusChangeTime, + accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes, + isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile, + isDirectory, isSymbolicLink, isSocket, + + -- * Creation + createNamedPipe, + createDevice, + + -- * Hard links + createLink, removeLink, + + -- * Symbolic links + createSymbolicLink, readSymbolicLink, + + -- * Renaming files + rename, + + -- * Changing file ownership + setOwnerAndGroup, setFdOwnerAndGroup, +#if HAVE_LCHOWN + setSymbolicLinkOwnerAndGroup, +#endif + + -- * Changing file timestamps + setFileTimes, setFileTimesHiRes, + setFdTimesHiRes, setSymbolicLinkTimesHiRes, + touchFile, touchFd, touchSymbolicLink, + + -- * Setting file sizes + setFileSize, setFdSize, + + -- * Find system-specific limits for a file + PathVar(..), getPathVar, getFdPathVar, + ) where + + +import Foreign +import Foreign.C + +import System.Posix.Types +import System.Posix.Files.Common +import System.Posix.Error +import System.Posix.Internals + +import Data.Time.Clock.POSIX (POSIXTime) + +-- ----------------------------------------------------------------------------- +-- chmod() + +-- | @setFileMode path mode@ changes permission of the file given by @path@ +-- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@ +-- doesn't exist or if the effective user ID of the current process is not that +-- of the file's owner. +-- +-- Note: calls @chmod@. +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = + withFilePath name $ \s -> do + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) + +-- ----------------------------------------------------------------------------- +-- access() + +-- | @fileAccess name read write exec@ checks if the file (or other file system +-- object) @name@ can be accessed for reading, writing and\/or executing. To +-- check a permission set the corresponding argument to 'True'. +-- +-- Note: calls @access@. +fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool +fileAccess name readOK writeOK execOK = access name flags + where + flags = read_f .|. write_f .|. exec_f + read_f = if readOK then (#const R_OK) else 0 + write_f = if writeOK then (#const W_OK) else 0 + exec_f = if execOK then (#const X_OK) else 0 + +-- | Checks for the existence of the file. +-- +-- Note: calls @access@. +fileExist :: FilePath -> IO Bool +fileExist name = + withFilePath name $ \s -> do + r <- c_access s (#const F_OK) + if (r == 0) + then return True + else do err <- getErrno + if (err == eNOENT) + then return False + else throwErrnoPath "fileExist" name + +access :: FilePath -> CMode -> IO Bool +access name flags = + withFilePath name $ \s -> do + r <- c_access s (fromIntegral flags) + if (r == 0) + then return True + else do err <- getErrno + if (err == eACCES || err == eROFS || err == eTXTBSY || + err == ePERM) + then return False + else throwErrnoPath "fileAccess" name + + +-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID, +-- size, access times, etc.) for the file @path@. +-- +-- Note: calls @stat@. +getFileStatus :: FilePath -> IO FileStatus +getFileStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1Retry_ "getFileStatus" path (c_stat s p) + return (FileStatus fp) + +-- | Acts as 'getFileStatus' except when the 'FilePath' refers to a symbolic +-- link. In that case the @FileStatus@ information of the symbolic link itself +-- is returned instead of that of the file it points to. +-- +-- Note: calls @lstat@. +getSymbolicLinkStatus :: FilePath -> IO FileStatus +getSymbolicLinkStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) + return (FileStatus fp) + +foreign import capi unsafe "HsUnix.h lstat" + c_lstat :: CString -> Ptr CStat -> IO CInt + +-- | @createNamedPipe fifo mode@ +-- creates a new named pipe, @fifo@, with permissions based on +-- @mode@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@ +-- already exists or if the effective user ID of the current process doesn't +-- have permission to create the pipe. +-- +-- Note: calls @mkfifo@. +createNamedPipe :: FilePath -> FileMode -> IO () +createNamedPipe name mode = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode) + +-- | @createDevice path mode dev@ creates either a regular or a special file +-- depending on the value of @mode@ (and @dev@). @mode@ will normally be either +-- 'blockSpecialMode' or 'characterSpecialMode'. May fail with +-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the +-- effective user ID of the current process doesn't have permission to create +-- the file. +-- +-- Note: calls @mknod@. +createDevice :: FilePath -> FileMode -> DeviceID -> IO () +createDevice path mode dev = + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev) + +foreign import capi unsafe "HsUnix.h mknod" + c_mknod :: CString -> CMode -> CDev -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Hard links + +-- | @createLink old new@ creates a new path, @new@, linked to an existing file, +-- @old@. +-- +-- Note: calls @link@. +createLink :: FilePath -> FilePath -> IO () +createLink name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2) + +-- | @removeLink path@ removes the link named @path@. +-- +-- Note: calls @unlink@. +removeLink :: FilePath -> IO () +removeLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s) + +-- ----------------------------------------------------------------------------- +-- Symbolic Links + +-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@ +-- which points to the file @file1@. +-- +-- Symbolic links are interpreted at run-time as if the contents of the link +-- had been substituted into the path being followed to find a file or directory. +-- +-- Note: calls @symlink@. +createSymbolicLink :: FilePath -> FilePath -> IO () +createSymbolicLink file1 file2 = + withFilePath file1 $ \s1 -> + withFilePath file2 $ \s2 -> + throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (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. +#if !defined(PATH_MAX) +-- PATH_MAX is not defined on systems with unlimited path length. +-- Ugly. Fix this. +#define PATH_MAX 4096 +#endif + +-- | Reads the @FilePath@ pointed to by the symbolic link and returns it. +-- +-- Note: calls @readlink@. +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 (#const PATH_MAX) $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf (#const PATH_MAX) + peekFilePathLen (buf,fromIntegral len) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Renaming files + +-- | @rename old new@ renames a file or directory from @old@ to @new@. +-- +-- Note: calls @rename@. +rename :: FilePath -> FilePath -> IO () +rename name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2) + +foreign import ccall unsafe "rename" + c_rename :: CString -> CString -> IO CInt + +-- ----------------------------------------------------------------------------- +-- chown() + +-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to +-- @uid@ and @gid@, respectively. +-- +-- If @uid@ or @gid@ is specified as -1, then that ID is not changed. +-- +-- Note: calls @chown@. +setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () +setOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid) + +foreign import ccall unsafe "chown" + c_chown :: CString -> CUid -> CGid -> IO CInt + +#if HAVE_LCHOWN +-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus +-- changes permissions on the link itself). +-- +-- Note: calls @lchown@. +setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () +setSymbolicLinkOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name + (c_lchown s uid gid) + +foreign import ccall unsafe "lchown" + c_lchown :: CString -> CUid -> CGid -> IO CInt +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file times + +-- | @setFileTimes path atime mtime@ sets the access and modification times +-- associated with file @path@ to @atime@ and @mtime@, respectively. +-- +-- Note: calls @utime@. +setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () +setFileTimes name atime mtime = do + withFilePath name $ \s -> + allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do + (#poke struct utimbuf, actime) p atime + (#poke struct utimbuf, modtime) p mtime + throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p) + +-- | Like 'setFileTimes' but timestamps can have sub-second resolution. +-- +-- Note: calls @utimensat@ or @utimes@. +-- +-- @since 2.7.0.0 +setFileTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () +#ifdef HAVE_UTIMENSAT +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times 0 +#else +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times) +#endif + +-- | Like 'setFileTimesHiRes' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @utimensat@ or @lutimes@. +-- +-- @since 2.7.0.0 +setSymbolicLinkTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () +#if HAVE_UTIMENSAT +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW) +#elif HAVE_LUTIMES +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_lutimes s times +#else +setSymbolicLinkTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + +-- | @touchFile path@ sets the access and modification times associated with +-- file @path@ to the current time. +-- +-- Note: calls @utime@. +touchFile :: FilePath -> IO () +touchFile name = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) + +-- | Like 'touchFile' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @lutimes@. +-- +-- @since 2.7.0.0 +touchSymbolicLink :: FilePath -> IO () +#if HAVE_LUTIMES +touchSymbolicLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr) +#else +touchSymbolicLink = + error "touchSymbolicLink: not available on this platform" +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file sizes + +-- | Truncates the file down to the specified length. If the file was larger +-- than the given length before this operation was performed the extra is lost. +-- +-- Note: calls @truncate@. +setFileSize :: FilePath -> FileOffset -> IO () +setFileSize file off = + withFilePath file $ \s -> + throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off) + +foreign import capi unsafe "HsUnix.h truncate" + c_truncate :: CString -> COff -> IO CInt + +-- ----------------------------------------------------------------------------- +-- pathconf()/fpathconf() support + +-- | @getPathVar var path@ obtains the dynamic value of the requested +-- configurable file limit or option associated with file or directory @path@. +-- For defined file limits, @getPathVar@ returns the associated +-- value. For defined file options, the result of @getPathVar@ +-- is undefined, but not failure. +-- +-- Note: calls @pathconf@. +getPathVar :: FilePath -> PathVar -> IO Limit +getPathVar name v = do + withFilePath name $ \ nameP -> + throwErrnoPathIfMinus1 "getPathVar" name $ + c_pathconf nameP (pathVarConst v) + +foreign import ccall unsafe "pathconf" + c_pathconf :: CString -> CInt -> IO CLong diff --git a/unix/System/Posix/Files/ByteString.hsc b/unix/System/Posix/Files/ByteString.hsc new file mode 100644 index 0000000..23a44e3 --- /dev/null +++ b/unix/System/Posix/Files/ByteString.hsc @@ -0,0 +1,448 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Files.ByteString +-- 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) +-- +-- Functions defined by the POSIX standards for manipulating and querying the +-- file system. Names of underlying POSIX functions are indicated whenever +-- possible. A more complete documentation of the POSIX functions together +-- with a more detailed description of different error conditions are usually +-- available in the system's manual pages or from +-- (free registration required). +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Files.ByteString ( + -- * File modes + -- FileMode exported by System.Posix.Types + unionFileModes, intersectFileModes, + nullFileMode, + ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes, + groupReadMode, groupWriteMode, groupExecuteMode, groupModes, + otherReadMode, otherWriteMode, otherExecuteMode, otherModes, + setUserIDMode, setGroupIDMode, + stdFileMode, accessModes, + fileTypeModes, + blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode, + directoryMode, symbolicLinkMode, socketMode, + + -- ** Setting file modes + setFileMode, setFdMode, setFileCreationMask, + + -- ** Checking file existence and permissions + fileAccess, fileExist, + + -- * File status + FileStatus, + -- ** Obtaining file status + getFileStatus, getFdStatus, getSymbolicLinkStatus, + -- ** Querying file status + deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup, + specialDeviceID, fileSize, accessTime, modificationTime, + statusChangeTime, + accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes, + isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile, + isDirectory, isSymbolicLink, isSocket, + + -- * Creation + createNamedPipe, + createDevice, + + -- * Hard links + createLink, removeLink, + + -- * Symbolic links + createSymbolicLink, readSymbolicLink, + + -- * Renaming files + rename, + + -- * Changing file ownership + setOwnerAndGroup, setFdOwnerAndGroup, +#if HAVE_LCHOWN + setSymbolicLinkOwnerAndGroup, +#endif + + -- * Changing file timestamps + setFileTimes, setFileTimesHiRes, + setFdTimesHiRes, setSymbolicLinkTimesHiRes, + touchFile, touchFd, touchSymbolicLink, + + -- * Setting file sizes + setFileSize, setFdSize, + + -- * Find system-specific limits for a file + PathVar(..), getPathVar, getFdPathVar, + ) where + +import System.Posix.Types +import System.Posix.Internals hiding (withFilePath, peekFilePathLen) +import Foreign +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.Posix.Files.Common +import System.Posix.ByteString.FilePath + +import Data.Time.Clock.POSIX (POSIXTime) + +-- ----------------------------------------------------------------------------- +-- chmod() + +-- | @setFileMode path mode@ changes permission of the file given by @path@ +-- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@ +-- doesn't exist or if the effective user ID of the current process is not that +-- of the file's owner. +-- +-- Note: calls @chmod@. +setFileMode :: RawFilePath -> FileMode -> IO () +setFileMode name m = + withFilePath name $ \s -> do + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) + + +-- ----------------------------------------------------------------------------- +-- access() + +-- | @fileAccess name read write exec@ checks if the file (or other file system +-- object) @name@ can be accessed for reading, writing and\/or executing. To +-- check a permission set the corresponding argument to 'True'. +-- +-- Note: calls @access@. +fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool +fileAccess name readOK writeOK execOK = access name flags + where + flags = read_f .|. write_f .|. exec_f + read_f = if readOK then (#const R_OK) else 0 + write_f = if writeOK then (#const W_OK) else 0 + exec_f = if execOK then (#const X_OK) else 0 + +-- | Checks for the existence of the file. +-- +-- Note: calls @access@. +fileExist :: RawFilePath -> IO Bool +fileExist name = + withFilePath name $ \s -> do + r <- c_access s (#const F_OK) + if (r == 0) + then return True + else do err <- getErrno + if (err == eNOENT) + then return False + else throwErrnoPath "fileExist" name + +access :: RawFilePath -> CMode -> IO Bool +access name flags = + withFilePath name $ \s -> do + r <- c_access s (fromIntegral flags) + if (r == 0) + then return True + else do err <- getErrno + if (err == eACCES || err == eROFS || err == eTXTBSY || + err == ePERM) + then return False + else throwErrnoPath "fileAccess" name + + +-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID, +-- size, access times, etc.) for the file @path@. +-- +-- Note: calls @stat@. +getFileStatus :: RawFilePath -> IO FileStatus +getFileStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1Retry_ "getFileStatus" path (c_stat s p) + return (FileStatus fp) + +-- | Acts as 'getFileStatus' except when the 'RawFilePath' refers to a symbolic +-- link. In that case the @FileStatus@ information of the symbolic link itself +-- is returned instead of that of the file it points to. +-- +-- Note: calls @lstat@. +getSymbolicLinkStatus :: RawFilePath -> IO FileStatus +getSymbolicLinkStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) + return (FileStatus fp) + +foreign import capi unsafe "HsUnix.h lstat" + c_lstat :: CString -> Ptr CStat -> IO CInt + +-- | @createNamedPipe fifo mode@ +-- creates a new named pipe, @fifo@, with permissions based on +-- @mode@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@ +-- already exists or if the effective user ID of the current process doesn't +-- have permission to create the pipe. +-- +-- Note: calls @mkfifo@. +createNamedPipe :: RawFilePath -> FileMode -> IO () +createNamedPipe name mode = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode) + +-- | @createDevice path mode dev@ creates either a regular or a special file +-- depending on the value of @mode@ (and @dev@). @mode@ will normally be either +-- 'blockSpecialMode' or 'characterSpecialMode'. May fail with +-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the +-- effective user ID of the current process doesn't have permission to create +-- the file. +-- +-- Note: calls @mknod@. +createDevice :: RawFilePath -> FileMode -> DeviceID -> IO () +createDevice path mode dev = + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev) + +foreign import capi unsafe "HsUnix.h mknod" + c_mknod :: CString -> CMode -> CDev -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Hard links + +-- | @createLink old new@ creates a new path, @new@, linked to an existing file, +-- @old@. +-- +-- Note: calls @link@. +createLink :: RawFilePath -> RawFilePath -> IO () +createLink name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2) + +-- | @removeLink path@ removes the link named @path@. +-- +-- Note: calls @unlink@. +removeLink :: RawFilePath -> IO () +removeLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s) + +-- ----------------------------------------------------------------------------- +-- Symbolic Links + +-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@ +-- which points to the file @file1@. +-- +-- Symbolic links are interpreted at run-time as if the contents of the link +-- had been substituted into the path being followed to find a file or directory. +-- +-- Note: calls @symlink@. +createSymbolicLink :: RawFilePath -> RawFilePath -> IO () +createSymbolicLink file1 file2 = + withFilePath file1 $ \s1 -> + withFilePath file2 $ \s2 -> + throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (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. +#if !defined(PATH_MAX) +-- PATH_MAX is not defined on systems with unlimited path length. +-- Ugly. Fix this. +#define PATH_MAX 4096 +#endif + +-- | Reads the @RawFilePath@ pointed to by the symbolic link and returns it. +-- +-- Note: calls @readlink@. +readSymbolicLink :: RawFilePath -> IO RawFilePath +readSymbolicLink file = + allocaArray0 (#const PATH_MAX) $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf (#const PATH_MAX) + peekFilePathLen (buf,fromIntegral len) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Renaming files + +-- | @rename old new@ renames a file or directory from @old@ to @new@. +-- +-- Note: calls @rename@. +rename :: RawFilePath -> RawFilePath -> IO () +rename name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2) + +foreign import ccall unsafe "rename" + c_rename :: CString -> CString -> IO CInt + +-- ----------------------------------------------------------------------------- +-- chown() + +-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to +-- @uid@ and @gid@, respectively. +-- +-- If @uid@ or @gid@ is specified as -1, then that ID is not changed. +-- +-- Note: calls @chown@. +setOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO () +setOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid) + +foreign import ccall unsafe "chown" + c_chown :: CString -> CUid -> CGid -> IO CInt + +#if HAVE_LCHOWN +-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus +-- changes permissions on the link itself). +-- +-- Note: calls @lchown@. +setSymbolicLinkOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO () +setSymbolicLinkOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name + (c_lchown s uid gid) + +foreign import ccall unsafe "lchown" + c_lchown :: CString -> CUid -> CGid -> IO CInt +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file times + +-- | @setFileTimes path atime mtime@ sets the access and modification times +-- associated with file @path@ to @atime@ and @mtime@, respectively. +-- +-- Note: calls @utime@. +setFileTimes :: RawFilePath -> EpochTime -> EpochTime -> IO () +setFileTimes name atime mtime = do + withFilePath name $ \s -> + allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do + (#poke struct utimbuf, actime) p atime + (#poke struct utimbuf, modtime) p mtime + throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p) + +-- | Like 'setFileTimes' but timestamps can have sub-second resolution. +-- +-- Note: calls @utimensat@ or @utimes@. +setFileTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO () +#ifdef HAVE_UTIMENSAT +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times 0 +#else +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times) +#endif + +-- | Like 'setFileTimesHiRes' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @utimensat@ or @lutimes@. +setSymbolicLinkTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO () +#if HAVE_UTIMENSAT +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW) +#elif HAVE_LUTIMES +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_lutimes s times +#else +setSymbolicLinkTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + +-- | @touchFile path@ sets the access and modification times associated with +-- file @path@ to the current time. +-- +-- Note: calls @utime@. +touchFile :: RawFilePath -> IO () +touchFile name = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) + +-- | Like 'touchFile' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @lutimes@. +touchSymbolicLink :: RawFilePath -> IO () +#if HAVE_LUTIMES +touchSymbolicLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr) +#else +touchSymbolicLink = + error "touchSymbolicLink: not available on this platform" +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file sizes + +-- | Truncates the file down to the specified length. If the file was larger +-- than the given length before this operation was performed the extra is lost. +-- +-- Note: calls @truncate@. +setFileSize :: RawFilePath -> FileOffset -> IO () +setFileSize file off = + withFilePath file $ \s -> + throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off) + +foreign import capi unsafe "HsUnix.h truncate" + c_truncate :: CString -> COff -> IO CInt + +-- ----------------------------------------------------------------------------- +-- pathconf()/fpathconf() support + +-- | @getPathVar var path@ obtains the dynamic value of the requested +-- configurable file limit or option associated with file or directory @path@. +-- For defined file limits, @getPathVar@ returns the associated +-- value. For defined file options, the result of @getPathVar@ +-- is undefined, but not failure. +-- +-- Note: calls @pathconf@. +getPathVar :: RawFilePath -> PathVar -> IO Limit +getPathVar name v = do + withFilePath name $ \ nameP -> + throwErrnoPathIfMinus1 "getPathVar" name $ + c_pathconf nameP (pathVarConst v) + +foreign import ccall unsafe "pathconf" + c_pathconf :: CString -> CInt -> IO CLong diff --git a/unix/System/Posix/Files/Common.hsc b/unix/System/Posix/Files/Common.hsc new file mode 100644 index 0000000..cc594cc --- /dev/null +++ b/unix/System/Posix/Files/Common.hsc @@ -0,0 +1,605 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Files.Common +-- 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) +-- +-- Functions defined by the POSIX standards for manipulating and querying the +-- file system. Names of underlying POSIX functions are indicated whenever +-- possible. A more complete documentation of the POSIX functions together +-- with a more detailed description of different error conditions are usually +-- available in the system's manual pages or from +-- (free registration required). +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Files.Common ( + -- * File modes + -- FileMode exported by System.Posix.Types + unionFileModes, intersectFileModes, + nullFileMode, + ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes, + groupReadMode, groupWriteMode, groupExecuteMode, groupModes, + otherReadMode, otherWriteMode, otherExecuteMode, otherModes, + setUserIDMode, setGroupIDMode, + stdFileMode, accessModes, + fileTypeModes, + blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode, + directoryMode, symbolicLinkMode, socketMode, + + -- ** Setting file modes + setFdMode, setFileCreationMask, + + -- * File status + FileStatus(..), + -- ** Obtaining file status + getFdStatus, + -- ** Querying file status + deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup, + specialDeviceID, fileSize, accessTime, modificationTime, + statusChangeTime, + accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes, + setFdTimesHiRes, touchFd, + isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile, + isDirectory, isSymbolicLink, isSocket, + + -- * Setting file sizes + setFdSize, + + -- * Changing file ownership + setFdOwnerAndGroup, + + -- * Find system-specific limits for a file + PathVar(..), getFdPathVar, pathVarConst, + + -- * Low level types and functions +#ifdef HAVE_UTIMENSAT + CTimeSpec(..), + toCTimeSpec, + c_utimensat, +#endif + CTimeVal(..), + toCTimeVal, + c_utimes, +#ifdef HAVE_LUTIMES + c_lutimes, +#endif + ) where + +import System.Posix.Types +import System.IO.Unsafe +import Data.Bits +import Data.Int +import Data.Ratio +import Data.Time.Clock.POSIX (POSIXTime) +import System.Posix.Internals +import Foreign.C +import Foreign.ForeignPtr +#if defined(HAVE_FUTIMES) || defined(HAVE_FUTIMENS) +import Foreign.Marshal (withArray) +#endif +import Foreign.Ptr +import Foreign.Storable + +-- ----------------------------------------------------------------------------- +-- POSIX file modes + +-- The abstract type 'FileMode', constants and operators for +-- manipulating the file modes defined by POSIX. + +-- | No permissions. +nullFileMode :: FileMode +nullFileMode = 0 + +-- | Owner has read permission. +ownerReadMode :: FileMode +ownerReadMode = (#const S_IRUSR) + +-- | Owner has write permission. +ownerWriteMode :: FileMode +ownerWriteMode = (#const S_IWUSR) + +-- | Owner has execute permission. +ownerExecuteMode :: FileMode +ownerExecuteMode = (#const S_IXUSR) + +-- | Group has read permission. +groupReadMode :: FileMode +groupReadMode = (#const S_IRGRP) + +-- | Group has write permission. +groupWriteMode :: FileMode +groupWriteMode = (#const S_IWGRP) + +-- | Group has execute permission. +groupExecuteMode :: FileMode +groupExecuteMode = (#const S_IXGRP) + +-- | Others have read permission. +otherReadMode :: FileMode +otherReadMode = (#const S_IROTH) + +-- | Others have write permission. +otherWriteMode :: FileMode +otherWriteMode = (#const S_IWOTH) + +-- | Others have execute permission. +otherExecuteMode :: FileMode +otherExecuteMode = (#const S_IXOTH) + +-- | Set user ID on execution. +setUserIDMode :: FileMode +setUserIDMode = (#const S_ISUID) + +-- | Set group ID on execution. +setGroupIDMode :: FileMode +setGroupIDMode = (#const S_ISGID) + +-- | Owner, group and others have read and write permission. +stdFileMode :: FileMode +stdFileMode = ownerReadMode .|. ownerWriteMode .|. + groupReadMode .|. groupWriteMode .|. + otherReadMode .|. otherWriteMode + +-- | Owner has read, write and execute permission. +ownerModes :: FileMode +ownerModes = (#const S_IRWXU) + +-- | Group has read, write and execute permission. +groupModes :: FileMode +groupModes = (#const S_IRWXG) + +-- | Others have read, write and execute permission. +otherModes :: FileMode +otherModes = (#const S_IRWXO) + +-- | Owner, group and others have read, write and execute permission. +accessModes :: FileMode +accessModes = ownerModes .|. groupModes .|. otherModes + +-- | Combines the two file modes into one that contains modes that appear in +-- either. +unionFileModes :: FileMode -> FileMode -> FileMode +unionFileModes m1 m2 = m1 .|. m2 + +-- | Combines two file modes into one that only contains modes that appear in +-- both. +intersectFileModes :: FileMode -> FileMode -> FileMode +intersectFileModes m1 m2 = m1 .&. m2 + +fileTypeModes :: FileMode +fileTypeModes = (#const S_IFMT) + +blockSpecialMode :: FileMode +blockSpecialMode = (#const S_IFBLK) + +characterSpecialMode :: FileMode +characterSpecialMode = (#const S_IFCHR) + +namedPipeMode :: FileMode +namedPipeMode = (#const S_IFIFO) + +regularFileMode :: FileMode +regularFileMode = (#const S_IFREG) + +directoryMode :: FileMode +directoryMode = (#const S_IFDIR) + +symbolicLinkMode :: FileMode +symbolicLinkMode = (#const S_IFLNK) + +socketMode :: FileMode +socketMode = (#const S_IFSOCK) + +-- | @setFdMode fd mode@ acts like 'setFileMode' but uses a file descriptor +-- @fd@ instead of a 'FilePath'. +-- +-- Note: calls @fchmod@. +setFdMode :: Fd -> FileMode -> IO () +setFdMode (Fd fd) m = + throwErrnoIfMinus1_ "setFdMode" (c_fchmod fd m) + +foreign import ccall unsafe "fchmod" + c_fchmod :: CInt -> CMode -> IO CInt + +-- | @setFileCreationMask mode@ sets the file mode creation mask to @mode@. +-- Modes set by this operation are subtracted from files and directories upon +-- creation. The previous file creation mask is returned. +-- +-- Note: calls @umask@. +setFileCreationMask :: FileMode -> IO FileMode +setFileCreationMask mask = c_umask mask + +-- ----------------------------------------------------------------------------- +-- stat() support + +-- | POSIX defines operations to get information, such as owner, permissions, +-- size and access times, about a file. This information is represented by the +-- 'FileStatus' type. +-- +-- Note: see @chmod@. +newtype FileStatus = FileStatus (ForeignPtr CStat) + +-- | ID of the device on which this file resides. +deviceID :: FileStatus -> DeviceID +-- | inode number +fileID :: FileStatus -> FileID +-- | File mode (such as permissions). +fileMode :: FileStatus -> FileMode +-- | Number of hard links to this file. +linkCount :: FileStatus -> LinkCount +-- | ID of owner. +fileOwner :: FileStatus -> UserID +-- | ID of group. +fileGroup :: FileStatus -> GroupID +-- | Describes the device that this file represents. +specialDeviceID :: FileStatus -> DeviceID +-- | Size of the file in bytes. If this file is a symbolic link the size is +-- the length of the pathname it contains. +fileSize :: FileStatus -> FileOffset +-- | Time of last access. +accessTime :: FileStatus -> EpochTime +-- | Time of last access in sub-second resolution. +accessTimeHiRes :: FileStatus -> POSIXTime +-- | Time of last modification. +modificationTime :: FileStatus -> EpochTime +-- | Time of last modification in sub-second resolution. +modificationTimeHiRes :: FileStatus -> POSIXTime +-- | Time of last status change (i.e. owner, group, link count, mode, etc.). +statusChangeTime :: FileStatus -> EpochTime +-- | Time of last status change (i.e. owner, group, link count, mode, etc.) in sub-second resolution. +statusChangeTimeHiRes :: FileStatus -> POSIXTime + +deviceID (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_dev) +fileID (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_ino) +fileMode (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_mode) +linkCount (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_nlink) +fileOwner (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_uid) +fileGroup (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_gid) +specialDeviceID (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_rdev) +fileSize (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_size) +accessTime (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_atime) +modificationTime (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_mtime) +statusChangeTime (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_ctime) + +accessTimeHiRes (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do + sec <- (#peek struct stat, st_atime) stat_ptr :: IO EpochTime +#ifdef HAVE_STRUCT_STAT_ST_ATIM + nsec <- (#peek struct stat, st_atim.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_ATIMESPEC + nsec <- (#peek struct stat, st_atimespec.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_ATIMENSEC + nsec <- (#peek struct stat, st_atimensec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_ATIME_N + nsec <- (#peek struct stat, st_atime_n) stat_ptr :: IO (#type int) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_UATIME + usec <- (#peek struct stat, st_uatime) stat_ptr :: IO (#type int) + let frac = toInteger usec % 10^(6::Int) +#else + let frac = 0 +#endif + return $ fromRational $ toRational sec + frac + +modificationTimeHiRes (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do + sec <- (#peek struct stat, st_mtime) stat_ptr :: IO EpochTime +#ifdef HAVE_STRUCT_STAT_ST_MTIM + nsec <- (#peek struct stat, st_mtim.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_MTIMESPEC + nsec <- (#peek struct stat, st_mtimespec.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_MTIMENSEC + nsec <- (#peek struct stat, st_mtimensec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_MTIME_N + nsec <- (#peek struct stat, st_mtime_n) stat_ptr :: IO (#type int) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_UMTIME + usec <- (#peek struct stat, st_umtime) stat_ptr :: IO (#type int) + let frac = toInteger usec % 10^(6::Int) +#else + let frac = 0 +#endif + return $ fromRational $ toRational sec + frac + +statusChangeTimeHiRes (FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do + sec <- (#peek struct stat, st_ctime) stat_ptr :: IO EpochTime +#ifdef HAVE_STRUCT_STAT_ST_CTIM + nsec <- (#peek struct stat, st_ctim.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_CTIMESPEC + nsec <- (#peek struct stat, st_ctimespec.tv_nsec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_CTIMENSEC + nsec <- (#peek struct stat, st_ctimensec) stat_ptr :: IO (#type long) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_CTIME_N + nsec <- (#peek struct stat, st_ctime_n) stat_ptr :: IO (#type int) + let frac = toInteger nsec % 10^(9::Int) +#elif HAVE_STRUCT_STAT_ST_UCTIME + usec <- (#peek struct stat, st_uctime) stat_ptr :: IO (#type int) + let frac = toInteger usec % 10^(6::Int) +#else + let frac = 0 +#endif + return $ fromRational $ toRational sec + frac + +-- | Checks if this file is a block device. +isBlockDevice :: FileStatus -> Bool +-- | Checks if this file is a character device. +isCharacterDevice :: FileStatus -> Bool +-- | Checks if this file is a named pipe device. +isNamedPipe :: FileStatus -> Bool +-- | Checks if this file is a regular file device. +isRegularFile :: FileStatus -> Bool +-- | Checks if this file is a directory device. +isDirectory :: FileStatus -> Bool +-- | Checks if this file is a symbolic link device. +isSymbolicLink :: FileStatus -> Bool +-- | Checks if this file is a socket device. +isSocket :: FileStatus -> Bool + +isBlockDevice stat = + (fileMode stat `intersectFileModes` fileTypeModes) == blockSpecialMode +isCharacterDevice stat = + (fileMode stat `intersectFileModes` fileTypeModes) == characterSpecialMode +isNamedPipe stat = + (fileMode stat `intersectFileModes` fileTypeModes) == namedPipeMode +isRegularFile stat = + (fileMode stat `intersectFileModes` fileTypeModes) == regularFileMode +isDirectory stat = + (fileMode stat `intersectFileModes` fileTypeModes) == directoryMode +isSymbolicLink stat = + (fileMode stat `intersectFileModes` fileTypeModes) == symbolicLinkMode +isSocket stat = + (fileMode stat `intersectFileModes` fileTypeModes) == socketMode + +-- | @getFdStatus fd@ acts as 'getFileStatus' but uses a file descriptor @fd@. +-- +-- Note: calls @fstat@. +getFdStatus :: Fd -> IO FileStatus +getFdStatus (Fd fd) = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getFdStatus" (c_fstat fd p) + return (FileStatus fp) + +-- ----------------------------------------------------------------------------- +-- Setting file times + +#if HAVE_UTIMENSAT || HAVE_FUTIMENS +data CTimeSpec = CTimeSpec EpochTime CLong + +instance Storable CTimeSpec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CInt) + poke p (CTimeSpec sec nsec) = do + (#poke struct timespec, tv_sec ) p sec + (#poke struct timespec, tv_nsec) p nsec + peek p = do + sec <- #{peek struct timespec, tv_sec } p + nsec <- #{peek struct timespec, tv_nsec} p + return $ CTimeSpec sec nsec + +toCTimeSpec :: POSIXTime -> CTimeSpec +toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac) + where + (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') + (sec', frac') = properFraction $ toRational t +#endif + +#ifdef HAVE_UTIMENSAT +foreign import ccall unsafe "utimensat" + c_utimensat :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt +#endif + +#if HAVE_FUTIMENS +foreign import ccall unsafe "futimens" + c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt +#endif + +data CTimeVal = CTimeVal CLong CLong + +instance Storable CTimeVal where + sizeOf _ = #size struct timeval + alignment _ = alignment (undefined :: CInt) + poke p (CTimeVal sec usec) = do + (#poke struct timeval, tv_sec ) p sec + (#poke struct timeval, tv_usec) p usec + peek p = do + sec <- #{peek struct timeval, tv_sec } p + usec <- #{peek struct timeval, tv_usec} p + return $ CTimeVal sec usec + +toCTimeVal :: POSIXTime -> CTimeVal +toCTimeVal t = CTimeVal sec (truncate $ 10^(6::Int) * frac) + where + (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') + (sec', frac') = properFraction $ toRational t + +foreign import ccall unsafe "utimes" + c_utimes :: CString -> Ptr CTimeVal -> IO CInt + +#ifdef HAVE_LUTIMES +foreign import ccall unsafe "lutimes" + c_lutimes :: CString -> Ptr CTimeVal -> IO CInt +#endif + +#if HAVE_FUTIMES +foreign import ccall unsafe "futimes" + c_futimes :: CInt -> Ptr CTimeVal -> IO CInt +#endif + +-- | Like 'setFileTimesHiRes' but uses a file descriptor instead of a path. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @futimens@ or @futimes@. +-- +-- @since 2.7.0.0 +setFdTimesHiRes :: Fd -> POSIXTime -> POSIXTime -> IO () +#if HAVE_FUTIMENS +setFdTimesHiRes (Fd fd) atime mtime = + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) +#elif HAVE_FUTIMES +setFdTimesHiRes (Fd fd) atime mtime = + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimes fd times) +#else +setFdTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + +-- | Like 'touchFile' but uses a file descriptor instead of a path. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @futimes@. +-- +-- @since 2.7.0.0 +touchFd :: Fd -> IO () +#if HAVE_FUTIMES +touchFd (Fd fd) = + throwErrnoIfMinus1_ "touchFd" (c_futimes fd nullPtr) +#else +touchFd = + error "touchFd: not available on this platform" +#endif + +-- ----------------------------------------------------------------------------- +-- fchown() + +-- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a +-- 'FilePath'. +-- +-- Note: calls @fchown@. +setFdOwnerAndGroup :: Fd -> UserID -> GroupID -> IO () +setFdOwnerAndGroup (Fd fd) uid gid = + throwErrnoIfMinus1_ "setFdOwnerAndGroup" (c_fchown fd uid gid) + +foreign import ccall unsafe "fchown" + c_fchown :: CInt -> CUid -> CGid -> IO CInt + +-- ----------------------------------------------------------------------------- +-- ftruncate() + +-- | Acts as 'setFileSize' but uses a file descriptor instead of a 'FilePath'. +-- +-- Note: calls @ftruncate@. +setFdSize :: Fd -> FileOffset -> IO () +setFdSize (Fd fd) off = + throwErrnoIfMinus1_ "setFdSize" (c_ftruncate fd off) + +-- ----------------------------------------------------------------------------- +-- pathconf()/fpathconf() support + +data PathVar + = FileSizeBits {- _PC_FILESIZEBITS -} + | LinkLimit {- _PC_LINK_MAX -} + | InputLineLimit {- _PC_MAX_CANON -} + | InputQueueLimit {- _PC_MAX_INPUT -} + | FileNameLimit {- _PC_NAME_MAX -} + | PathNameLimit {- _PC_PATH_MAX -} + | PipeBufferLimit {- _PC_PIPE_BUF -} + -- These are described as optional in POSIX: + {- _PC_ALLOC_SIZE_MIN -} + {- _PC_REC_INCR_XFER_SIZE -} + {- _PC_REC_MAX_XFER_SIZE -} + {- _PC_REC_MIN_XFER_SIZE -} + {- _PC_REC_XFER_ALIGN -} + | SymbolicLinkLimit {- _PC_SYMLINK_MAX -} + | SetOwnerAndGroupIsRestricted {- _PC_CHOWN_RESTRICTED -} + | FileNamesAreNotTruncated {- _PC_NO_TRUNC -} + | VDisableChar {- _PC_VDISABLE -} + | AsyncIOAvailable {- _PC_ASYNC_IO -} + | PrioIOAvailable {- _PC_PRIO_IO -} + | SyncIOAvailable {- _PC_SYNC_IO -} + +pathVarConst :: PathVar -> CInt +pathVarConst v = case v of + LinkLimit -> (#const _PC_LINK_MAX) + InputLineLimit -> (#const _PC_MAX_CANON) + InputQueueLimit -> (#const _PC_MAX_INPUT) + FileNameLimit -> (#const _PC_NAME_MAX) + PathNameLimit -> (#const _PC_PATH_MAX) + PipeBufferLimit -> (#const _PC_PIPE_BUF) + SetOwnerAndGroupIsRestricted -> (#const _PC_CHOWN_RESTRICTED) + FileNamesAreNotTruncated -> (#const _PC_NO_TRUNC) + VDisableChar -> (#const _PC_VDISABLE) + +#ifdef _PC_SYNC_IO + SyncIOAvailable -> (#const _PC_SYNC_IO) +#else + SyncIOAvailable -> error "_PC_SYNC_IO not available" +#endif + +#ifdef _PC_ASYNC_IO + AsyncIOAvailable -> (#const _PC_ASYNC_IO) +#else + AsyncIOAvailable -> error "_PC_ASYNC_IO not available" +#endif + +#ifdef _PC_PRIO_IO + PrioIOAvailable -> (#const _PC_PRIO_IO) +#else + PrioIOAvailable -> error "_PC_PRIO_IO not available" +#endif + +#if _PC_FILESIZEBITS + FileSizeBits -> (#const _PC_FILESIZEBITS) +#else + FileSizeBits -> error "_PC_FILESIZEBITS not available" +#endif + +#if _PC_SYMLINK_MAX + SymbolicLinkLimit -> (#const _PC_SYMLINK_MAX) +#else + SymbolicLinkLimit -> error "_PC_SYMLINK_MAX not available" +#endif + +-- | @getFdPathVar var fd@ obtains the dynamic value of the requested +-- configurable file limit or option associated with the file or directory +-- attached to the open channel @fd@. For defined file limits, @getFdPathVar@ +-- returns the associated value. For defined file options, the result of +-- @getFdPathVar@ is undefined, but not failure. +-- +-- Note: calls @fpathconf@. +getFdPathVar :: Fd -> PathVar -> IO Limit +getFdPathVar (Fd fd) v = + throwErrnoIfMinus1 "getFdPathVar" $ + c_fpathconf fd (pathVarConst v) + +foreign import ccall unsafe "fpathconf" + c_fpathconf :: CInt -> CInt -> IO CLong diff --git a/unix/System/Posix/IO.hsc b/unix/System/Posix/IO.hsc new file mode 100644 index 0000000..438c44c --- /dev/null +++ b/unix/System/Posix/IO.hsc @@ -0,0 +1,92 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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. These types and functions correspond to the unix +-- functions open(2), close(2), etc. For more portable functions +-- which are more like fopen(3) and friends from stdio.h, see +-- "System.IO". +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +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 + -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that + -- EAGAIN exceptions may occur for non-blocking IO! + + fdRead, fdWrite, + fdReadBuf, fdWriteBuf, + + -- ** 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.Posix.Types +import System.Posix.Error +import System.Posix.IO.Common +import System.Posix.Internals ( withFilePath ) + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: FilePath + -> OpenMode + -> OpenFileFlags + -> IO Fd +openFd name how flags = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how flags + +-- |Create and open this file in WriteOnly mode. A special case of +-- 'openFd'. See 'System.Posix.Files' for information on how to use +-- the 'FileMode' type. + +createFile :: FilePath -> FileMode -> IO Fd +createFile name mode + = openFd name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } diff --git a/unix/System/Posix/IO/ByteString.hsc b/unix/System/Posix/IO/ByteString.hsc new file mode 100644 index 0000000..6bbfed1 --- /dev/null +++ b/unix/System/Posix/IO/ByteString.hsc @@ -0,0 +1,92 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.IO.ByteString +-- 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. These types and functions correspond to the unix +-- functions open(2), close(2), etc. For more portable functions +-- which are more like fopen(3) and friends from stdio.h, see +-- "System.IO". +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.IO.ByteString ( + -- * Input \/ Output + + -- ** Standard file descriptors + stdInput, stdOutput, stdError, + + -- ** Opening and closing files + OpenMode(..), + OpenFileFlags(..), defaultFileFlags, + openFd, createFile, + closeFd, + + -- ** Reading\/writing data + -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that + -- EAGAIN exceptions may occur for non-blocking IO! + + fdRead, fdWrite, + fdReadBuf, fdWriteBuf, + + -- ** 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.Posix.Types +import System.Posix.IO.Common + +import System.Posix.ByteString.FilePath + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: RawFilePath + -> OpenMode + -> OpenFileFlags + -> IO Fd +openFd name how flags = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how flags + +-- |Create and open this file in WriteOnly mode. A special case of +-- 'openFd'. See 'System.Posix.Files' for information on how to use +-- the 'FileMode' type. + +createFile :: RawFilePath -> FileMode -> IO Fd +createFile name mode + = openFd name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } diff --git a/unix/System/Posix/IO/Common.hsc b/unix/System/Posix/IO/Common.hsc new file mode 100644 index 0000000..e751938 --- /dev/null +++ b/unix/System/Posix/IO/Common.hsc @@ -0,0 +1,443 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE RecordWildCards #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.IO.Common +-- 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) +-- +----------------------------------------------------------------------------- + +module System.Posix.IO.Common ( + -- * Input \/ Output + + -- ** Standard file descriptors + stdInput, stdOutput, stdError, + + -- ** Opening and closing files + OpenMode(..), + OpenFileFlags(..), defaultFileFlags, + open_, + closeFd, + + -- ** Reading\/writing data + -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that + -- EAGAIN exceptions may occur for non-blocking IO! + + fdRead, fdWrite, + fdReadBuf, fdWriteBuf, + + -- ** 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 qualified System.Posix.Internals as Base + +import Foreign +import Foreign.C + +import GHC.IO.Handle.Internals +import GHC.IO.Handle.Types +import qualified GHC.IO.FD as FD +import qualified GHC.IO.Handle.FD as FD +import GHC.IO.Exception +import Data.Typeable (cast) + +#include "HsUnix.h" + +-- ----------------------------------------------------------------------------- +-- Pipes +-- |The 'createPipe' function creates a pair of connected file +-- descriptors. The first component is the fd to read from, the second +-- is the write end. Although pipes may be bidirectional, this +-- behaviour is not portable and programmers should use two separate +-- pipes for this purpose. May throw an exception if this is an +-- invalid descriptor. + +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 (Fd rfd, Fd wfd) + +foreign import ccall unsafe "pipe" + c_pipe :: Ptr CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Duplicating file descriptors + +-- | May throw an exception if this is an invalid descriptor. +dup :: Fd -> IO Fd +dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r) + +-- | May throw an exception if this is an invalid descriptor. +dupTo :: Fd -> Fd -> IO Fd +dupTo (Fd fd1) (Fd fd2) = do + r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2) + return (Fd r) + +foreign import ccall unsafe "dup" + c_dup :: CInt -> IO CInt + +foreign import ccall unsafe "dup2" + c_dup2 :: CInt -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- 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 + deriving (Read, Show, Eq, Ord) + +-- |Correspond to some of the int flags from C's fcntl.h. +data OpenFileFlags = + OpenFileFlags { + append :: Bool, -- ^ O_APPEND + exclusive :: Bool, -- ^ O_EXCL + -- + -- __NOTE__: Result is undefined if 'creat' is 'Nothing'. + noctty :: Bool, -- ^ O_NOCTTY + nonBlock :: Bool, -- ^ O_NONBLOCK + trunc :: Bool, -- ^ O_TRUNC + nofollow :: Bool, -- ^ O_NOFOLLOW + -- + -- @since 2.8.0.0 + creat :: Maybe FileMode, -- ^ O_CREAT + -- + -- @since 2.8.0.0 + cloexec :: Bool, -- ^ O_CLOEXEC + -- + -- @since 2.8.0.0 + directory :: Bool, -- ^ O_DIRECTORY + -- + -- @since 2.8.0.0 + sync :: Bool -- ^ O_SYNC + -- + -- @since 2.8.0.0 + } + deriving (Read, Show, Eq, Ord) + + +-- | Default values for the 'OpenFileFlags' type. +-- +-- Each field of 'OpenFileFlags' is either 'False' or 'Nothing' +-- respectively. +defaultFileFlags :: OpenFileFlags +defaultFileFlags = + OpenFileFlags { + append = False, + exclusive = False, + noctty = False, + nonBlock = False, + trunc = False, + nofollow = False, + creat = Nothing, + cloexec = False, + directory = False, + sync = False + } + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +open_ :: CString + -> OpenMode + -> OpenFileFlags + -> IO Fd +open_ str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag + nonBlockFlag truncateFlag nofollowFlag + creatFlag cloexecFlag directoryFlag + syncFlag) = do + fd <- c_open str all_flags mode_w + return (Fd fd) + where + all_flags = creat .|. flags .|. open_mode + + flags = + (if appendFlag then (#const O_APPEND) else 0) .|. + (if exclusiveFlag then (#const O_EXCL) else 0) .|. + (if nocttyFlag then (#const O_NOCTTY) else 0) .|. + (if nonBlockFlag then (#const O_NONBLOCK) else 0) .|. + (if truncateFlag then (#const O_TRUNC) else 0) .|. + (if nofollowFlag then (#const O_NOFOLLOW) else 0) .|. + (if cloexecFlag then (#const O_CLOEXEC) else 0) .|. + (if directoryFlag then (#const O_DIRECTORY) else 0) .|. + (if syncFlag then (#const O_SYNC) else 0) + + (creat, mode_w) = case creatFlag 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 capi unsafe "HsUnix.h open" + c_open :: CString -> CInt -> CMode -> IO CInt + +-- |Close this file descriptor. May throw an exception if this is an +-- invalid descriptor. + +closeFd :: Fd -> IO () +closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) +-- Here we don't to retry on EINTR because according to +-- http://pubs.opengroup.org/onlinepubs/9699919799/functions/close.html +-- "with errno set to [EINTR] [...] the state of fildes is unspecified" +-- and on Linux, already the first close() removes the FD from the process's +-- FD table so closing a second time is invalid +-- (see http://man7.org/linux/man-pages/man2/close.2.html#NOTES). + +foreign import ccall unsafe "HsUnix.h close" + c_close :: CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Converting file descriptors to/from Handles + +-- | Extracts the 'Fd' from a 'Handle'. This function has the side effect +-- of closing the 'Handle' and flushing its write buffer, if necessary. +handleToFd :: Handle -> IO Fd + +-- | Converts an 'Fd' into a 'Handle' that can be used with the +-- standard Haskell IO library (see "System.IO"). +fdToHandle :: Fd -> IO Handle +fdToHandle fd = FD.fdToHandle (fromIntegral fd) + +handleToFd h@(FileHandle _ m) = do + withHandle' "handleToFd" h m $ handleToFd' h +handleToFd h@(DuplexHandle _ r w) = do + _ <- withHandle' "handleToFd" h r $ handleToFd' h + withHandle' "handleToFd" h w $ handleToFd' h + -- for a DuplexHandle, make sure we mark both sides as closed, + -- otherwise a finalizer will come along later and close the other + -- side. (#3914) + +handleToFd' :: Handle -> Handle__ -> IO (Handle__, Fd) +handleToFd' h h_@Handle__{haType=_,..} = do + case cast haDevice of + Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation + "handleToFd" (Just h) Nothing) + "handle is not a file descriptor") + Just fd -> do + -- converting a Handle into an Fd effectively means + -- letting go of the Handle; it is put into a closed + -- state as a result. + flushWriteBuffer h_ + FD.release fd + return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd)) + + +-- ----------------------------------------------------------------------------- +-- Fd options + +data FdOption = AppendOnWrite -- ^O_APPEND + | CloseOnExec -- ^FD_CLOEXEC + | NonBlockingRead -- ^O_NONBLOCK + | SynchronousWrites -- ^O_SYNC + +fdOption2Int :: FdOption -> CInt +fdOption2Int CloseOnExec = (#const FD_CLOEXEC) +fdOption2Int AppendOnWrite = (#const O_APPEND) +fdOption2Int NonBlockingRead = (#const O_NONBLOCK) +fdOption2Int SynchronousWrites = (#const O_SYNC) + +-- | May throw an exception if this is an invalid descriptor. +queryFdOption :: Fd -> FdOption -> IO Bool +queryFdOption (Fd fd) opt = do + r <- throwErrnoIfMinus1 "queryFdOption" (Base.c_fcntl_read fd flag) + return ((r .&. fdOption2Int opt) /= 0) + where + flag = case opt of + CloseOnExec -> (#const F_GETFD) + _ -> (#const F_GETFL) + +-- | May throw an exception if this is an invalid descriptor. +setFdOption :: Fd -> FdOption -> Bool -> IO () +setFdOption (Fd fd) opt val = do + r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag) + let r' | val = r .|. opt_val + | otherwise = r .&. (complement opt_val) + throwErrnoIfMinus1_ "setFdOption" + (Base.c_fcntl_write fd setflag (fromIntegral r')) + where + (getflag,setflag)= case opt of + CloseOnExec -> ((#const F_GETFD),(#const F_SETFD)) + _ -> ((#const F_GETFL),(#const F_SETFL)) + opt_val = fdOption2Int opt + +-- ----------------------------------------------------------------------------- +-- Seeking + +mode2Int :: SeekMode -> CInt +mode2Int AbsoluteSeek = (#const SEEK_SET) +mode2Int RelativeSeek = (#const SEEK_CUR) +mode2Int SeekFromEnd = (#const SEEK_END) + +-- | May throw an exception if this is an invalid descriptor. +fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset +fdSeek (Fd fd) mode off = + throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode)) + +-- ----------------------------------------------------------------------------- +-- Locking + +data LockRequest = ReadLock + | WriteLock + | Unlock + +type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset) + +-- | May throw an exception if this is an invalid descriptor. +getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock)) +getLock (Fd fd) lock = + allocaLock lock $ \p_flock -> do + throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock) + result <- bytes2ProcessIDAndLock p_flock + return (maybeResult result) + where + maybeResult (_, (Unlock, _, _, _)) = Nothing + maybeResult x = Just x + +allocaLock :: FileLock -> (Ptr Base.CFLock -> IO a) -> IO a +allocaLock (lockreq, mode, start, len) io = + allocaBytes (#const sizeof(struct flock)) $ \p -> do + (#poke struct flock, l_type) p (lockReq2Int 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 + +lockReq2Int :: LockRequest -> CShort +lockReq2Int ReadLock = (#const F_RDLCK) +lockReq2Int WriteLock = (#const F_WRLCK) +lockReq2Int Unlock = (#const F_UNLCK) + +bytes2ProcessIDAndLock :: Ptr Base.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 _ = error $ "int2req: bad argument" + + int2mode :: CShort -> SeekMode + int2mode (#const SEEK_SET) = AbsoluteSeek + int2mode (#const SEEK_CUR) = RelativeSeek + int2mode (#const SEEK_END) = SeekFromEnd + int2mode _ = error $ "int2mode: bad argument" + +-- | May throw an exception if this is an invalid descriptor. +setLock :: Fd -> FileLock -> IO () +setLock (Fd fd) lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock) + +-- | May throw an exception if this is an invalid descriptor. +waitToSetLock :: Fd -> FileLock -> IO () +waitToSetLock (Fd fd) lock = do + allocaLock lock $ \p_flock -> + throwErrnoIfMinus1_ "waitToSetLock" + (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock) + +-- ----------------------------------------------------------------------------- +-- fd{Read,Write} + +-- | 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 + -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read. +fdRead _fd 0 = return ("", 0) +fdRead fd nbytes = do + allocaBytes (fromIntegral nbytes) $ \ buf -> do + rc <- fdReadBuf fd buf nbytes + case rc of + 0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF") + n -> do + s <- peekCStringLen (castPtr buf, fromIntegral n) + return (s, n) + +-- | Read data from an 'Fd' into memory. This is exactly equivalent +-- to the POSIX @read@ function. +fdReadBuf :: Fd + -> Ptr Word8 -- ^ Memory in which to put the data + -> ByteCount -- ^ Maximum number of bytes to read + -> IO ByteCount -- ^ Number of bytes read (zero for EOF) +fdReadBuf _fd _buf 0 = return 0 +fdReadBuf fd buf nbytes = + fmap fromIntegral $ + throwErrnoIfMinus1Retry "fdReadBuf" $ + 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' using the locale encoding. +fdWrite :: Fd -> String -> IO ByteCount +fdWrite fd str = + 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. +fdWriteBuf :: Fd + -> Ptr Word8 -- ^ Memory containing the data to write + -> ByteCount -- ^ Maximum number of bytes to write + -> IO ByteCount -- ^ Number of bytes written +fdWriteBuf fd buf len = + fmap fromIntegral $ + throwErrnoIfMinus1Retry "fdWriteBuf" $ + 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/unix/System/Posix/Process.hsc b/unix/System/Posix/Process.hsc new file mode 100644 index 0000000..afdb164 --- /dev/null +++ b/unix/System/Posix/Process.hsc @@ -0,0 +1,125 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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. See also the System.Cmd and System.Process +-- modules in the process package. +-- +----------------------------------------------------------------------------- + +module System.Posix.Process ( + -- * Processes + + -- ** Forking and executing + forkProcess, + forkProcessWithUnmask, + executeFile, + + -- ** Exiting + exitImmediately, + + -- ** Process environment + getProcessID, + getParentProcessID, + + -- ** Process groups + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, + joinProcessGroup, + setProcessGroupIDOf, + + -- ** Sessions + createSession, + + -- ** Process times + ProcessTimes(..), + getProcessTimes, + + -- ** Scheduling priority + nice, + getProcessPriority, + getProcessGroupPriority, + getUserPriority, + setProcessPriority, + setProcessGroupPriority, + setUserPriority, + + -- ** Process status + ProcessStatus(..), + getProcessStatus, + getAnyProcessStatus, + getGroupProcessStatus, + + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + + ) where + +#include "HsUnix.h" + +import Foreign +import Foreign.C +import System.Posix.Process.Internals +import System.Posix.Process.Common +import System.Posix.Internals ( withFilePath ) + +-- | @'executeFile' cmd args env@ calls one of the +-- @execv*@ family, depending on whether or not the current +-- PATH is to be searched for the command, and whether or not an +-- environment is provided to supersede the process's current +-- environment. The basename (leading directory names suppressed) of +-- the command is passed to @execv*@ as @arg[0]@; +-- the argument list passed to 'executeFile' therefore +-- begins with @arg[1]@. +executeFile :: FilePath -- ^ Command + -> Bool -- ^ Search PATH? + -> [String] -- ^ Arguments + -> Maybe [(String, String)] -- ^ Environment + -> IO a +executeFile path search args Nothing = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) + else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) + return undefined -- never reached + +executeFile path search args (Just env) = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arg_arr -> + let env' = map (\ (name, val) -> name ++ ('=' : val)) env in + withMany withFilePath env' $ \cenv -> + withArray0 nullPtr cenv $ \env_arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path + (c_execvpe s arg_arr env_arr) + else throwErrnoPathIfMinus1_ "executeFile" path + (c_execve s arg_arr env_arr) + return undefined -- never reached + +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 "execve" + c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt + diff --git a/unix/System/Posix/Process/ByteString.hsc b/unix/System/Posix/Process/ByteString.hsc new file mode 100644 index 0000000..39da5ba --- /dev/null +++ b/unix/System/Posix/Process/ByteString.hsc @@ -0,0 +1,136 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Process.ByteString +-- 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. See also the System.Cmd and System.Process +-- modules in the process package. +-- +----------------------------------------------------------------------------- + +module System.Posix.Process.ByteString ( + -- * Processes + + -- ** Forking and executing + forkProcess, + forkProcessWithUnmask, + executeFile, + + -- ** Exiting + exitImmediately, + + -- ** Process environment + getProcessID, + getParentProcessID, + + -- ** Process groups + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, + joinProcessGroup, + setProcessGroupIDOf, + + -- ** Sessions + createSession, + + -- ** Process times + ProcessTimes(..), + getProcessTimes, + + -- ** Scheduling priority + nice, + getProcessPriority, + getProcessGroupPriority, + getUserPriority, + setProcessPriority, + setProcessGroupPriority, + setUserPriority, + + -- ** Process status + ProcessStatus(..), + getProcessStatus, + getAnyProcessStatus, + getGroupProcessStatus, + + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + + ) where + +#include "HsUnix.h" + +import Foreign +import System.Posix.Process.Internals +import System.Posix.Process.Common + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC + +import System.Posix.ByteString.FilePath + +-- | @'executeFile' cmd args env@ calls one of the +-- @execv*@ family, depending on whether or not the current +-- PATH is to be searched for the command, and whether or not an +-- environment is provided to supersede the process's current +-- environment. The basename (leading directory names suppressed) of +-- the command is passed to @execv*@ as @arg[0]@; +-- the argument list passed to 'executeFile' therefore +-- begins with @arg[1]@. +executeFile :: RawFilePath -- ^ Command + -> Bool -- ^ Search PATH? + -> [ByteString] -- ^ Arguments + -> Maybe [(ByteString, ByteString)] -- ^ Environment + -> IO a +executeFile path search args Nothing = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) + else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) + return undefined -- never reached + +executeFile path search args (Just env) = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arg_arr -> + let env' = map (\ (name, val) -> name `BC.append` ('=' `BC.cons` val)) env in + withMany withFilePath env' $ \cenv -> + withArray0 nullPtr cenv $ \env_arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path + (c_execvpe s arg_arr env_arr) + else throwErrnoPathIfMinus1_ "executeFile" path + (c_execve s arg_arr env_arr) + return undefined -- never reached + +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 "execve" + c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt diff --git a/unix/System/Posix/Process/Common.hsc b/unix/System/Posix/Process/Common.hsc new file mode 100644 index 0000000..e070dd1 --- /dev/null +++ b/unix/System/Posix/Process/Common.hsc @@ -0,0 +1,430 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE InterruptibleFFI, RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Process.Common +-- 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. See also the System.Cmd and System.Process +-- modules in the process package. +-- +----------------------------------------------------------------------------- + +module System.Posix.Process.Common ( + -- * Processes + + -- ** Forking and executing + forkProcess, + forkProcessWithUnmask, + + -- ** Exiting + exitImmediately, + + -- ** Process environment + getProcessID, + getParentProcessID, + + -- ** Process groups + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, + joinProcessGroup, + setProcessGroupIDOf, + + -- ** Sessions + createSession, + + -- ** Process times + ProcessTimes(..), + getProcessTimes, + + -- ** Scheduling priority + nice, + getProcessPriority, + getProcessGroupPriority, + getUserPriority, + setProcessPriority, + setProcessGroupPriority, + setUserPriority, + + -- ** Process status + ProcessStatus(..), + getProcessStatus, + getAnyProcessStatus, + getGroupProcessStatus, + + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + + ) where + +#include "HsUnix.h" + +import Foreign.C.Error +import Foreign.C.Types +import Foreign.Marshal.Alloc ( alloca, allocaBytes ) +import Foreign.Ptr ( Ptr ) +import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr ) +import Foreign.Storable ( Storable(..) ) +import System.Exit +import System.Posix.Process.Internals +import System.Posix.Types +import Control.Monad + +import Control.Exception.Base ( bracket, getMaskingState, MaskingState(..) ) -- used by forkProcess +import GHC.TopHandler ( runIO ) +import GHC.IO ( unsafeUnmask, uninterruptibleMask_ ) + +-- ----------------------------------------------------------------------------- +-- Process environment + +-- | 'getProcessID' calls @getpid@ to obtain the 'ProcessID' for +-- the current process. +getProcessID :: IO ProcessID +getProcessID = c_getpid + +foreign import ccall unsafe "getpid" + c_getpid :: IO CPid + +-- | 'getProcessID' calls @getppid@ to obtain the 'ProcessID' for +-- the parent of the current process. +getParentProcessID :: IO ProcessID +getParentProcessID = c_getppid + +foreign import ccall unsafe "getppid" + c_getppid :: IO CPid + +-- | 'getProcessGroupID' calls @getpgrp@ to obtain the +-- 'ProcessGroupID' for the current process. +getProcessGroupID :: IO ProcessGroupID +getProcessGroupID = c_getpgrp + +foreign import ccall unsafe "getpgrp" + c_getpgrp :: IO CPid + +-- | @'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. +createProcessGroupFor :: ProcessID -> IO ProcessGroupID +createProcessGroupFor pid = do + throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0) + return pid + +-- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the +-- 'ProcessGroupID' of the current process to @pgid@. +joinProcessGroup :: ProcessGroupID -> IO () +joinProcessGroup pgid = + throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 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 + +-- | 'createSession' calls @setsid@ to create a new session +-- with the current process as session leader. +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' calls @times@ to obtain time-accounting +-- information for the current process and its children. +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 + }) + +data {-# CTYPE "struct tms" #-} CTms + +foreign import capi unsafe "HsUnix.h times" + c_times :: Ptr CTms -> IO CClock + +-- ----------------------------------------------------------------------------- +-- Process scheduling priority + +nice :: Int -> IO () +nice prio = do + resetErrno + res <- c_nice (fromIntegral prio) + when (res == -1) $ do + err <- getErrno + when (err /= eOK) (throwErrno "nice") + +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' corresponds to the POSIX @fork@ system call. +The 'IO' action passed as an argument is executed in the child process; no other +threads will be copied to the child process. +On success, 'forkProcess' returns the child's 'ProcessID' to the parent process; +in case of an error, an exception is thrown. + +The exception masking state of the executed action is inherited +(c.f. 'forkIO'), see also 'forkProcessWithUnmask' (/since: 2.7.0.0/). + +'forkProcess' comes with a giant warning: since any other running +threads are not copied into the child process, it's easy to go wrong: +e.g. by accessing some shared resource that was held by another thread +in the parent. +-} + +forkProcess :: IO () -> IO ProcessID +forkProcess action = do + -- wrap action to re-establish caller's masking state, as + -- 'forkProcessPrim' starts in 'MaskedInterruptible' state by + -- default; see also #1048 + mstate <- getMaskingState + let action' = case mstate of + Unmasked -> unsafeUnmask action + MaskedInterruptible -> action + MaskedUninterruptible -> uninterruptibleMask_ action + + bracket + (newStablePtr (runIO action')) + freeStablePtr + (\stable -> throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)) + +foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid + +-- | Variant of 'forkProcess' in the style of 'forkIOWithUnmask'. +-- +-- @since 2.7.0.0 +forkProcessWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ProcessID +forkProcessWithUnmask action = forkProcess (action unsafeUnmask) + +-- ----------------------------------------------------------------------------- +-- Waiting for process termination + +-- | @'getProcessStatus' blk stopped pid@ calls @waitpid@, returning +-- @'Just' tc@, the 'ProcessStatus' for process @pid@ if it is +-- available, 'Nothing' otherwise. If @blk@ is 'False', then +-- @WNOHANG@ is set in the options for @waitpid@, otherwise not. +-- If @stopped@ is 'True', then @WUNTRACED@ is set in the +-- options for @waitpid@, otherwise not. +getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus) +getProcessStatus block stopped pid = + alloca $ \wstatp -> do + pid' <- throwErrnoIfMinus1Retry "getProcessStatus" + (c_waitpid pid wstatp (waitOptions block stopped)) + case pid' of + 0 -> return Nothing + _ -> do ps <- readWaitStatus wstatp + return (Just ps) + +-- safe/interruptible, because this call might block +foreign import ccall interruptible "waitpid" + c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid + +-- | @'getGroupProcessStatus' blk stopped pgid@ calls @waitpid@, +-- returning @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' +-- for any process in group @pgid@ if one is available, or 'Nothing' +-- if there are child processes but none have exited. If there are +-- no child processes, then 'getGroupProcessStatus' raises an +-- 'isDoesNotExistError' exception. +-- +-- If @blk@ is 'False', then @WNOHANG@ is set in the options for +-- @waitpid@, otherwise not. If @stopped@ is 'True', then +-- @WUNTRACED@ is set in the options for @waitpid@, otherwise not. +getGroupProcessStatus :: Bool + -> Bool + -> ProcessGroupID + -> IO (Maybe (ProcessID, ProcessStatus)) +getGroupProcessStatus block stopped pgid = + alloca $ \wstatp -> do + pid <- throwErrnoIfMinus1Retry "getGroupProcessStatus" + (c_waitpid (-pgid) wstatp (waitOptions block stopped)) + case pid of + 0 -> return Nothing + _ -> do ps <- readWaitStatus wstatp + return (Just (pid, ps)) + +-- | @'getAnyProcessStatus' blk stopped@ calls @waitpid@, returning +-- @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' for any +-- child process if a child process has exited, or 'Nothing' if +-- there are child processes but none have exited. If there are no +-- child processes, then 'getAnyProcessStatus' raises an +-- 'isDoesNotExistError' exception. +-- +-- If @blk@ is 'False', then @WNOHANG@ is set in the options for +-- @waitpid@, otherwise not. If @stopped@ is 'True', then +-- @WUNTRACED@ is set in the options for @waitpid@, otherwise not. +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 + +readWaitStatus :: Ptr CInt -> IO ProcessStatus +readWaitStatus wstatp = do + wstat <- peek wstatp + decipherWaitStatus wstat + +-- ----------------------------------------------------------------------------- +-- Exiting + +-- | @'exitImmediately' status@ calls @_exit@ to terminate the process +-- with the indicated exit @status@. +-- The operation never returns. Since it does not use the Haskell exception +-- system and it cannot be caught. +-- +-- Note: Prior to @unix-2.8.0.0@ the type-signature of 'exitImmediately' was +-- @ExitCode -> IO ()@. +-- +-- @since 2.8.0.0 +exitImmediately :: ExitCode -> IO a +exitImmediately status = do + _ <- c_exit (exitcode2Int status) + -- The above will exit the program, but need the following to satisfy + -- the type signature. + exitImmediately status + where + exitcode2Int ExitSuccess = 0 + exitcode2Int (ExitFailure n) = fromIntegral n + +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." #-} -- deprecated in 7.2 +-- | @'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." #-} -- deprecated in 7.2 +-- | @'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/unix/System/Posix/Process/Internals.hs b/unix/System/Posix/Process/Internals.hs new file mode 100644 index 0000000..ddafa10 --- /dev/null +++ b/unix/System/Posix/Process/Internals.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE Trustworthy #-} + +module System.Posix.Process.Internals ( + pPrPr_disableITimers, c_execvpe, + decipherWaitStatus, ProcessStatus(..) ) where + +import Foreign +import Foreign.C +import System.Exit +import System.IO.Error +import GHC.Conc (Signal) + +-- | The exit status of a process +data ProcessStatus + = Exited ExitCode -- ^ the process exited by calling + -- @exit()@ or returning from @main@ + | Terminated Signal Bool -- ^ the process was terminated by a + -- signal, the @Bool@ is @True@ if a core + -- dump was produced + -- + -- @since 2.7.0.0 + | Stopped Signal -- ^ the process was stopped by a signal + deriving (Eq, Ord, Show) + +-- this function disables the itimer, which would otherwise cause confusing +-- signals to be sent to the new process. +foreign import capi unsafe "Rts.h stopTimer" + pPrPr_disableITimers :: IO () + +foreign import ccall unsafe "__hsunix_execvpe" + c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt + +decipherWaitStatus :: CInt -> IO ProcessStatus +decipherWaitStatus wstat = + 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 + let coredumped = c_WCOREDUMP wstat /= 0 + return (Terminated termsig coredumped) + else do + if c_WIFSTOPPED wstat /= 0 + then do + let stopsig = c_WSTOPSIG wstat + return (Stopped stopsig) + else do + ioError (mkIOError illegalOperationErrorType + "waitStatus" Nothing Nothing) + + +foreign import capi unsafe "HsUnix.h WIFEXITED" + c_WIFEXITED :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WEXITSTATUS" + c_WEXITSTATUS :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WIFSIGNALED" + c_WIFSIGNALED :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WTERMSIG" + c_WTERMSIG :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WIFSTOPPED" + c_WIFSTOPPED :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WSTOPSIG" + c_WSTOPSIG :: CInt -> CInt + +foreign import capi unsafe "HsUnix.h WCOREDUMP" + c_WCOREDUMP :: CInt -> CInt + diff --git a/unix/System/Posix/Resource.hsc b/unix/System/Posix/Resource.hsc new file mode 100644 index 0000000..0511a0c --- /dev/null +++ b/unix/System/Posix/Resource.hsc @@ -0,0 +1,166 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Resource +-- Copyright : (c) The University of Glasgow 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX resource support +-- +----------------------------------------------------------------------------- + +module System.Posix.Resource ( + -- * Resource Limits + ResourceLimit(..), ResourceLimits(..), Resource(..), + getResourceLimit, + setResourceLimit, + ) where + +#include "HsUnix.h" + +import System.Posix.Types +import Foreign +import Foreign.C + +-- ----------------------------------------------------------------------------- +-- Resource limits + +data Resource + = ResourceCoreFileSize + | ResourceCPUTime + | ResourceDataSize + | ResourceFileSize + | ResourceOpenFiles + | ResourceStackSize +#ifdef RLIMIT_AS + | ResourceTotalMemory +#endif + deriving Eq + +data ResourceLimits + = ResourceLimits { softLimit, hardLimit :: ResourceLimit } + deriving Eq + +data ResourceLimit + = ResourceLimitInfinity + | ResourceLimitUnknown + | ResourceLimit Integer + deriving Eq + +data {-# CTYPE "struct rlimit" #-} RLimit + +foreign import capi unsafe "HsUnix.h getrlimit" + c_getrlimit :: CInt -> Ptr RLimit -> IO CInt + +foreign import capi unsafe "HsUnix.h setrlimit" + c_setrlimit :: CInt -> Ptr RLimit -> IO CInt + +getResourceLimit :: Resource -> IO ResourceLimits +getResourceLimit res = do + allocaBytes (#const sizeof(struct rlimit)) $ \p_rlimit -> do + throwErrnoIfMinus1_ "getResourceLimit" $ + c_getrlimit (packResource res) p_rlimit + soft <- (#peek struct rlimit, rlim_cur) p_rlimit + hard <- (#peek struct rlimit, rlim_max) p_rlimit + return (ResourceLimits { + softLimit = unpackRLimit soft, + hardLimit = unpackRLimit hard + }) + +setResourceLimit :: Resource -> ResourceLimits -> IO () +setResourceLimit res ResourceLimits{softLimit=soft,hardLimit=hard} = do + allocaBytes (#const sizeof(struct rlimit)) $ \p_rlimit -> do + (#poke struct rlimit, rlim_cur) p_rlimit (packRLimit soft True) + (#poke struct rlimit, rlim_max) p_rlimit (packRLimit hard False) + throwErrnoIfMinus1_ "setResourceLimit" $ + c_setrlimit (packResource res) p_rlimit + return () + +packResource :: Resource -> CInt +packResource ResourceCoreFileSize = (#const RLIMIT_CORE) +packResource ResourceCPUTime = (#const RLIMIT_CPU) +packResource ResourceDataSize = (#const RLIMIT_DATA) +packResource ResourceFileSize = (#const RLIMIT_FSIZE) +packResource ResourceOpenFiles = (#const RLIMIT_NOFILE) +packResource ResourceStackSize = (#const RLIMIT_STACK) +#ifdef RLIMIT_AS +packResource ResourceTotalMemory = (#const RLIMIT_AS) +#endif + +unpackRLimit :: CRLim -> ResourceLimit +unpackRLimit (#const RLIM_INFINITY) = ResourceLimitInfinity +unpackRLimit other +#if defined(RLIM_SAVED_MAX) + | ((#const RLIM_SAVED_MAX) :: CRLim) /= (#const RLIM_INFINITY) && + other == (#const RLIM_SAVED_MAX) = ResourceLimitUnknown +#endif +#if defined(RLIM_SAVED_CUR) + | ((#const RLIM_SAVED_CUR) :: CRLim) /= (#const RLIM_INFINITY) && + other == (#const RLIM_SAVED_CUR) = ResourceLimitUnknown +#endif + | otherwise = ResourceLimit (fromIntegral other) + +packRLimit :: ResourceLimit -> Bool -> CRLim +packRLimit ResourceLimitInfinity _ = (#const RLIM_INFINITY) +#if defined(RLIM_SAVED_CUR) +packRLimit ResourceLimitUnknown True = (#const RLIM_SAVED_CUR) +#endif +#if defined(RLIM_SAVED_MAX) +packRLimit ResourceLimitUnknown False = (#const RLIM_SAVED_MAX) +#endif +#if ! defined(RLIM_SAVED_MAX) && !defined(RLIM_SAVED_CUR) +packRLimit ResourceLimitUnknown _ = + error + $ "System.Posix.Resource.packRLimit: " ++ + "ResourceLimitUnknown but RLIM_SAVED_MAX/RLIM_SAVED_CUR not defined by platform" +#endif +packRLimit (ResourceLimit other) _ = fromIntegral other + + +-- ----------------------------------------------------------------------------- +-- Test code + +{- +import System.Posix +import Control.Monad + +main = do + zipWithM_ (\r n -> setResourceLimit r ResourceLimits{ + hardLimit = ResourceLimit n, + softLimit = ResourceLimit n }) + allResources [1..] + showAll + mapM_ (\r -> setResourceLimit r ResourceLimits{ + hardLimit = ResourceLimit 1, + softLimit = ResourceLimitInfinity }) + allResources + -- should fail + + +showAll = + mapM_ (\r -> getResourceLimit r >>= (putStrLn . showRLims)) allResources + +allResources = + [ResourceCoreFileSize, ResourceCPUTime, ResourceDataSize, + ResourceFileSize, ResourceOpenFiles, ResourceStackSize +#ifdef RLIMIT_AS + , ResourceTotalMemory +#endif + ] + +showRLims ResourceLimits{hardLimit=h,softLimit=s} + = "hard: " ++ showRLim h ++ ", soft: " ++ showRLim s + +showRLim ResourceLimitInfinity = "infinity" +showRLim ResourceLimitUnknown = "unknown" +showRLim (ResourceLimit other) = show other +-} diff --git a/unix/System/Posix/Semaphore.hsc b/unix/System/Posix/Semaphore.hsc new file mode 100644 index 0000000..12db924 --- /dev/null +++ b/unix/System/Posix/Semaphore.hsc @@ -0,0 +1,131 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Semaphore +-- Copyright : (c) Daniel Franke 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires POSIX) +-- +-- POSIX named semaphore support. +-- +----------------------------------------------------------------------------- + +module System.Posix.Semaphore + (OpenSemFlags(..), Semaphore(), + semOpen, semUnlink, semWait, semTryWait, semThreadWait, + semPost, semGetValue) + where + +#include +#include + +import Foreign.C +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Types +import Control.Concurrent +import Data.Bits + +data OpenSemFlags = OpenSemFlags { semCreate :: Bool, + -- ^ If true, create the semaphore if it + -- does not yet exist. + semExclusive :: Bool + -- ^ If true, throw an exception if the + -- semaphore already exists. + } + +newtype Semaphore = Semaphore (ForeignPtr ()) + +-- | Open a named semaphore with the given name, flags, mode, and initial +-- value. +semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore +semOpen name flags mode value = + let cflags = (if semCreate flags then #{const O_CREAT} else 0) .|. + (if semExclusive flags then #{const O_EXCL} else 0) + semOpen' cname = + do sem <- throwErrnoPathIfNull "semOpen" name $ + sem_open cname (toEnum cflags) mode (toEnum value) + fptr <- newForeignPtr sem (finalize sem) + return $ Semaphore fptr + finalize sem = throwErrnoPathIfMinus1_ "semOpen" name $ + sem_close sem in + withCAString name semOpen' + +-- | Delete the semaphore with the given name. +semUnlink :: String -> IO () +semUnlink name = withCAString name semUnlink' + where semUnlink' cname = throwErrnoPathIfMinus1_ "semUnlink" name $ + sem_unlink cname + +-- | Lock the semaphore, blocking until it becomes available. Since this +-- is done through a system call, this will block the *entire runtime*, +-- not just the current thread. If this is not the behaviour you want, +-- use semThreadWait instead. +semWait :: Semaphore -> IO () +semWait (Semaphore fptr) = withForeignPtr fptr semWait' + where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $ + sem_wait sem + +-- | Attempt to lock the semaphore without blocking. Immediately return +-- False if it is not available. +semTryWait :: Semaphore -> IO Bool +semTryWait (Semaphore fptr) = withForeignPtr fptr semTrywait' + where semTrywait' sem = do res <- sem_trywait sem + (if res == 0 then return True + else do errno <- getErrno + (if errno == eINTR + then semTrywait' sem + else if errno == eAGAIN + then return False + else throwErrno "semTrywait")) + +-- | Poll the semaphore until it is available, then lock it. Unlike +-- semWait, this will block only the current thread rather than the +-- entire process. +semThreadWait :: Semaphore -> IO () +semThreadWait sem = do res <- semTryWait sem + (if res then return () + else ( do { yield; semThreadWait sem } )) + +-- | Unlock the semaphore. +semPost :: Semaphore -> IO () +semPost (Semaphore fptr) = withForeignPtr fptr semPost' + where semPost' sem = throwErrnoIfMinus1Retry_ "semPost" $ + sem_post sem + +-- | Return the semaphore's current value. +semGetValue :: Semaphore -> IO Int +semGetValue (Semaphore fptr) = withForeignPtr fptr semGetValue' + where semGetValue' sem = alloca (semGetValue_ sem) + +semGetValue_ :: Ptr () -> Ptr CInt -> IO Int +semGetValue_ sem ptr = do throwErrnoIfMinus1Retry_ "semGetValue" $ + sem_getvalue sem ptr + cint <- peek ptr + return $ fromEnum cint + +foreign import ccall safe "sem_open" + sem_open :: CString -> CInt -> CMode -> CUInt -> IO (Ptr ()) +foreign import ccall safe "sem_close" + sem_close :: Ptr () -> IO CInt +foreign import ccall safe "sem_unlink" + sem_unlink :: CString -> IO CInt + +foreign import ccall safe "sem_wait" + sem_wait :: Ptr () -> IO CInt +foreign import ccall safe "sem_trywait" + sem_trywait :: Ptr () -> IO CInt +foreign import ccall safe "sem_post" + sem_post :: Ptr () -> IO CInt +foreign import ccall safe "sem_getvalue" + sem_getvalue :: Ptr () -> Ptr CInt -> IO Int diff --git a/unix/System/Posix/SharedMem.hsc b/unix/System/Posix/SharedMem.hsc new file mode 100644 index 0000000..ab31764 --- /dev/null +++ b/unix/System/Posix/SharedMem.hsc @@ -0,0 +1,91 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.SharedMem +-- Copyright : (c) Daniel Franke 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires POSIX) +-- +-- POSIX shared memory support. +-- +----------------------------------------------------------------------------- + +module System.Posix.SharedMem + (ShmOpenFlags(..), shmOpen, shmUnlink) + where + +#include "HsUnix.h" + +#include +#include +#include + +import System.Posix.Types +#if defined(HAVE_SHM_OPEN) || defined(HAVE_SHM_UNLINK) +import Foreign.C +#endif +#ifdef HAVE_SHM_OPEN +import Data.Bits +#endif + +data ShmOpenFlags = ShmOpenFlags + { shmReadWrite :: Bool, + -- ^ If true, open the shm object read-write rather than read-only. + shmCreate :: Bool, + -- ^ If true, create the shm object if it does not exist. + shmExclusive :: Bool, + -- ^ If true, throw an exception if the shm object already exists. + shmTrunc :: Bool + -- ^ If true, wipe the contents of the shm object after opening it. + } + +-- | Open a shared memory object with the given name, flags, and mode. +shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd +#ifdef HAVE_SHM_OPEN +shmOpen name flags mode = + do cflags0 <- return 0 + cflags1 <- return $ cflags0 .|. (if shmReadWrite flags + then #{const O_RDWR} + else #{const O_RDONLY}) + cflags2 <- return $ cflags1 .|. (if shmCreate flags then #{const O_CREAT} + else 0) + cflags3 <- return $ cflags2 .|. (if shmExclusive flags + then #{const O_EXCL} + else 0) + cflags4 <- return $ cflags3 .|. (if shmTrunc flags then #{const O_TRUNC} + else 0) + withCAString name (shmOpen' cflags4) + where shmOpen' cflags cname = + do fd <- throwErrnoIfMinus1 "shmOpen" $ + shm_open cname cflags mode + return $ Fd fd +#else +shmOpen = error "System.Posix.SharedMem:shm_open: not available" +#endif + +-- | Delete the shared memory object with the given name. +shmUnlink :: String -> IO () +#ifdef HAVE_SHM_UNLINK +shmUnlink name = withCAString name shmUnlink' + where shmUnlink' cname = + throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname +#else +shmUnlink = error "System.Posix.SharedMem:shm_unlink: not available" +#endif + +#ifdef HAVE_SHM_OPEN +foreign import ccall unsafe "shm_open" + shm_open :: CString -> CInt -> CMode -> IO CInt +#endif + +#ifdef HAVE_SHM_UNLINK +foreign import ccall unsafe "shm_unlink" + shm_unlink :: CString -> IO CInt +#endif diff --git a/unix/System/Posix/Signals.hsc b/unix/System/Posix/Signals.hsc new file mode 100644 index 0000000..e978884 --- /dev/null +++ b/unix/System/Posix/Signals.hsc @@ -0,0 +1,706 @@ +{-# LANGUAGE CApiFFI, CPP, DeriveDataTypeable, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fno-cse #-} -- global variables +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Signals +-- 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 signal support +-- +----------------------------------------------------------------------------- + +#include "HsUnixConfig.h" +##include "HsUnixConfig.h" + +#ifdef HAVE_SIGNAL_H +#include +#endif + +module System.Posix.Signals ( + -- * The Signal type + Signal, + + -- * Specific signals + nullSignal, + internalAbort, sigABRT, + realTimeAlarm, sigALRM, + busError, sigBUS, + processStatusChanged, sigCHLD, + continueProcess, sigCONT, + floatingPointException, sigFPE, + lostConnection, sigHUP, + illegalInstruction, sigILL, + keyboardSignal, sigINT, + killProcess, sigKILL, + openEndedPipe, sigPIPE, + keyboardTermination, sigQUIT, + segmentationViolation, sigSEGV, + softwareStop, sigSTOP, + softwareTermination, sigTERM, + keyboardStop, sigTSTP, + backgroundRead, sigTTIN, + backgroundWrite, sigTTOU, + userDefinedSignal1, sigUSR1, + userDefinedSignal2, sigUSR2, +#if CONST_SIGPOLL != -1 + pollableEvent, sigPOLL, +#endif + profilingTimerExpired, sigPROF, + badSystemCall, sigSYS, + breakpointTrap, sigTRAP, + urgentDataAvailable, sigURG, + virtualTimerExpired, sigVTALRM, + cpuTimeLimitExceeded, sigXCPU, + fileSizeLimitExceeded, sigXFSZ, + + -- * Sending signals + raiseSignal, + signalProcess, + signalProcessGroup, + + -- * Handling signals + Handler(Default,Ignore,Catch,CatchOnce,CatchInfo,CatchInfoOnce), + SignalInfo(..), SignalSpecificInfo(..), + installHandler, + + -- * Signal sets + SignalSet, + emptySignalSet, fullSignalSet, reservedSignals, + addSignal, deleteSignal, inSignalSet, + + -- * The process signal mask + getSignalMask, setSignalMask, blockSignals, unblockSignals, + + -- * The alarm timer + scheduleAlarm, + + -- * Waiting for signals + getPendingSignals, + awaitSignal, + + -- * The @NOCLDSTOP@ flag + setStoppedChildFlag, queryStoppedChildFlag, + + -- MISSING FUNCTIONALITY: + -- sigaction(), (inc. the sigaction structure + flags etc.) + -- the siginfo structure + -- sigaltstack() + -- sighold, sigignore, sigpause, sigrelse, sigset + -- siginterrupt + ) where + +import Data.Word +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types +import System.Posix.Internals +import System.Posix.Process +import System.Posix.Process.Internals +import Data.Dynamic + +##include "rts/Signals.h" + +import GHC.Conc hiding (Signal) + +-- ----------------------------------------------------------------------------- +-- Specific signals + +nullSignal :: Signal +nullSignal = 0 + +-- | Process abort signal. +sigABRT :: CInt +sigABRT = CONST_SIGABRT + +-- | Alarm clock. +sigALRM :: CInt +sigALRM = CONST_SIGALRM + +-- | Access to an undefined portion of a memory object. +sigBUS :: CInt +sigBUS = CONST_SIGBUS + +-- | Child process terminated, stopped, or continued. +sigCHLD :: CInt +sigCHLD = CONST_SIGCHLD + +-- | Continue executing, if stopped. +sigCONT :: CInt +sigCONT = CONST_SIGCONT + +-- | Erroneous arithmetic operation. +sigFPE :: CInt +sigFPE = CONST_SIGFPE + +-- | Hangup. +sigHUP :: CInt +sigHUP = CONST_SIGHUP + +-- | Illegal instruction. +sigILL :: CInt +sigILL = CONST_SIGILL + +-- | Terminal interrupt signal. +sigINT :: CInt +sigINT = CONST_SIGINT + +-- | Kill (cannot be caught or ignored). +sigKILL :: CInt +sigKILL = CONST_SIGKILL + +-- | Write on a pipe with no one to read it. +sigPIPE :: CInt +sigPIPE = CONST_SIGPIPE + +-- | Terminal quit signal. +sigQUIT :: CInt +sigQUIT = CONST_SIGQUIT + +-- | Invalid memory reference. +sigSEGV :: CInt +sigSEGV = CONST_SIGSEGV + +-- | Stop executing (cannot be caught or ignored). +sigSTOP :: CInt +sigSTOP = CONST_SIGSTOP + +-- | Termination signal. +sigTERM :: CInt +sigTERM = CONST_SIGTERM + +-- | Terminal stop signal. +sigTSTP :: CInt +sigTSTP = CONST_SIGTSTP + +-- | Background process attempting read. +sigTTIN :: CInt +sigTTIN = CONST_SIGTTIN + +-- | Background process attempting write. +sigTTOU :: CInt +sigTTOU = CONST_SIGTTOU + +-- | User-defined signal 1. +sigUSR1 :: CInt +sigUSR1 = CONST_SIGUSR1 + +-- | User-defined signal 2. +sigUSR2 :: CInt +sigUSR2 = CONST_SIGUSR2 + +#if CONST_SIGPOLL != -1 +-- | Pollable event. +sigPOLL :: CInt +sigPOLL = CONST_SIGPOLL +#endif + +-- | Profiling timer expired. +sigPROF :: CInt +sigPROF = CONST_SIGPROF + +-- | Bad system call. +sigSYS :: CInt +sigSYS = CONST_SIGSYS + +-- | Trace/breakpoint trap. +sigTRAP :: CInt +sigTRAP = CONST_SIGTRAP + +-- | High bandwidth data is available at a socket. +sigURG :: CInt +sigURG = CONST_SIGURG + +-- | Virtual timer expired. +sigVTALRM :: CInt +sigVTALRM = CONST_SIGVTALRM + +-- | CPU time limit exceeded. +sigXCPU :: CInt +sigXCPU = CONST_SIGXCPU + +-- | File size limit exceeded. +sigXFSZ :: CInt +sigXFSZ = CONST_SIGXFSZ + +-- | Alias for 'sigABRT'. +internalAbort ::Signal +internalAbort = sigABRT + +-- | Alias for 'sigALRM'. +realTimeAlarm :: Signal +realTimeAlarm = sigALRM + +-- | Alias for 'sigBUS'. +busError :: Signal +busError = sigBUS + +-- | Alias for 'sigCHLD'. +processStatusChanged :: Signal +processStatusChanged = sigCHLD + +-- | Alias for 'sigCONT'. +continueProcess :: Signal +continueProcess = sigCONT + +-- | Alias for 'sigFPE'. +floatingPointException :: Signal +floatingPointException = sigFPE + +-- | Alias for 'sigHUP'. +lostConnection :: Signal +lostConnection = sigHUP + +-- | Alias for 'sigILL'. +illegalInstruction :: Signal +illegalInstruction = sigILL + +-- | Alias for 'sigINT'. +keyboardSignal :: Signal +keyboardSignal = sigINT + +-- | Alias for 'sigKILL'. +killProcess :: Signal +killProcess = sigKILL + +-- | Alias for 'sigPIPE'. +openEndedPipe :: Signal +openEndedPipe = sigPIPE + +-- | Alias for 'sigQUIT'. +keyboardTermination :: Signal +keyboardTermination = sigQUIT + +-- | Alias for 'sigSEGV'. +segmentationViolation :: Signal +segmentationViolation = sigSEGV + +-- | Alias for 'sigSTOP'. +softwareStop :: Signal +softwareStop = sigSTOP + +-- | Alias for 'sigTERM'. +softwareTermination :: Signal +softwareTermination = sigTERM + +-- | Alias for 'sigTSTP'. +keyboardStop :: Signal +keyboardStop = sigTSTP + +-- | Alias for 'sigTTIN'. +backgroundRead :: Signal +backgroundRead = sigTTIN + +-- | Alias for 'sigTTOU'. +backgroundWrite :: Signal +backgroundWrite = sigTTOU + +-- | Alias for 'sigUSR1'. +userDefinedSignal1 :: Signal +userDefinedSignal1 = sigUSR1 + +-- | Alias for 'sigUSR2'. +userDefinedSignal2 :: Signal +userDefinedSignal2 = sigUSR2 + +#if CONST_SIGPOLL != -1 +-- | Alias for 'sigPOLL'. +pollableEvent :: Signal +pollableEvent = sigPOLL +#endif + +-- | Alias for 'sigPROF'. +profilingTimerExpired :: Signal +profilingTimerExpired = sigPROF + +-- | Alias for 'sigSYS'. +badSystemCall :: Signal +badSystemCall = sigSYS + +-- | Alias for 'sigTRAP'. +breakpointTrap :: Signal +breakpointTrap = sigTRAP + +-- | Alias for 'sigURG'. +urgentDataAvailable :: Signal +urgentDataAvailable = sigURG + +-- | Alias for 'sigVTALRM'. +virtualTimerExpired :: Signal +virtualTimerExpired = sigVTALRM + +-- | Alias for 'sigXCPU'. +cpuTimeLimitExceeded :: Signal +cpuTimeLimitExceeded = sigXCPU + +-- | Alias for 'sigXFSZ'. +fileSizeLimitExceeded :: Signal +fileSizeLimitExceeded = sigXFSZ + +-- ----------------------------------------------------------------------------- +-- Signal-related functions + +-- | @signalProcess int pid@ calls @kill@ to signal process @pid@ +-- with interrupt signal @int@. +signalProcess :: Signal -> ProcessID -> IO () +signalProcess sig pid + = throwErrnoIfMinus1_ "signalProcess" (c_kill pid sig) + +foreign import ccall unsafe "kill" + c_kill :: CPid -> CInt -> IO CInt + + +-- | @signalProcessGroup int pgid@ calls @kill@ to signal +-- all processes in group @pgid@ with interrupt signal @int@. +signalProcessGroup :: Signal -> ProcessGroupID -> IO () +signalProcessGroup sig pgid + = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg pgid sig) + +foreign import ccall unsafe "killpg" + c_killpg :: CPid -> CInt -> IO CInt + +-- | @raiseSignal int@ calls @kill@ to signal the current process +-- with interrupt signal @int@. +raiseSignal :: Signal -> IO () +raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig) + +-- See also note in GHC's rts/RtsUtils.c +-- This is somewhat fragile because we need to keep the +-- `#if`-conditional in sync with GHC's runtime. +#if (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(darwin_HOST_OS)) +foreign import ccall unsafe "genericRaise" + c_raise :: CInt -> IO CInt +#else +foreign import ccall unsafe "raise" + c_raise :: CInt -> IO CInt +#endif + + +type Signal = CInt + +-- | The actions to perform when a signal is received. +data Handler = Default + | Ignore + -- not yet: | Hold + | Catch (IO ()) + | CatchOnce (IO ()) + | CatchInfo (SignalInfo -> IO ()) -- ^ @since 2.7.0.0 + | CatchInfoOnce (SignalInfo -> IO ()) -- ^ @since 2.7.0.0 + deriving (Typeable) + +-- | Information about a received signal (derived from @siginfo_t@). +-- +-- @since 2.7.0.0 +data SignalInfo = SignalInfo { + siginfoSignal :: Signal, + siginfoError :: Errno, + siginfoSpecific :: SignalSpecificInfo + } + +-- | Information specific to a particular type of signal +-- (derived from @siginfo_t@). +-- +-- @since 2.7.0.0 +data SignalSpecificInfo + = NoSignalSpecificInfo + | SigChldInfo { + siginfoPid :: ProcessID, + siginfoUid :: UserID, + siginfoStatus :: ProcessStatus + } + +-- | @installHandler int handler iset@ calls @sigaction@ to install an +-- interrupt handler for signal @int@. If @handler@ is @Default@, +-- @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is +-- installed; if @handler@ is @Catch action@, a handler is installed +-- which will invoke @action@ in a new thread when (or shortly after) the +-- signal is received. +-- If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure +-- is set to @s@; otherwise it is cleared. The previously installed +-- signal handler for @int@ is returned +installHandler :: Signal + -> Handler + -> Maybe SignalSet -- ^ other signals to block + -> IO Handler -- ^ old handler + +#ifdef __PARALLEL_HASKELL__ +installHandler = + error "installHandler: not available for Parallel Haskell" +#else + +installHandler sig handler _maybe_mask = do + ensureIOManagerIsRunning -- for the threaded RTS + + -- if we're setting the action to DFL or IGN, we should do that *first* + -- if we're setting a handler, + -- if the previous action was handle, then setHandler is ok + -- if the previous action was IGN/DFL, then setHandler followed by sig_install + (old_action, old_handler) <- + case handler of + Ignore -> do + old_action <- stg_sig_install sig STG_SIG_IGN nullPtr + old_handler <- setHandler sig Nothing + return (old_action, old_handler) + + Default -> do + old_action <- stg_sig_install sig STG_SIG_DFL nullPtr + old_handler <- setHandler sig Nothing + return (old_action, old_handler) + + _some_kind_of_catch -> do + -- I don't think it's possible to get CatchOnce right. If + -- there's a signal in flight, then we might run the handler + -- more than once. + let dyn = toDyn handler + old_handler <- case handler of + Catch action -> setHandler sig (Just (const action,dyn)) + CatchOnce action -> setHandler sig (Just (const action,dyn)) + CatchInfo action -> setHandler sig (Just (getinfo action,dyn)) + CatchInfoOnce action -> setHandler sig (Just (getinfo action,dyn)) +#if __GLASGOW_HASKELL__ < 811 + _ -> error "installHandler" +#endif + + let action = case handler of + Catch _ -> STG_SIG_HAN + CatchOnce _ -> STG_SIG_RST + CatchInfo _ -> STG_SIG_HAN + CatchInfoOnce _ -> STG_SIG_RST +#if __GLASGOW_HASKELL__ < 811 + _ -> error "installHandler" +#endif + + old_action <- stg_sig_install sig action nullPtr + -- mask is pointless, so leave it NULL + + return (old_action, old_handler) + + case (old_handler,old_action) of + (_, STG_SIG_DFL) -> return $ Default + (_, STG_SIG_IGN) -> return $ Ignore + (Nothing, _) -> return $ Ignore + (Just (_,dyn), _) + | Just h <- fromDynamic dyn -> return h + | Just io <- fromDynamic dyn -> return (Catch io) + -- handlers put there by the base package have type IO () + | otherwise -> return Default + +foreign import ccall unsafe + stg_sig_install + :: CInt -- sig no. + -> CInt -- action code (STG_SIG_HAN etc.) + -> Ptr CSigset -- (in, out) blocked + -> IO CInt -- (ret) old action code + +getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO () +getinfo handler fp_info = do + si <- unmarshalSigInfo fp_info + handler si + +unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo +unmarshalSigInfo fp = do + withForeignPtr fp $ \p -> do + sig <- (#peek siginfo_t, si_signo) p + errno <- (#peek siginfo_t, si_errno) p + extra <- case sig of + _ | sig == sigCHLD -> do + pid <- (#peek siginfo_t, si_pid) p + uid <- (#peek siginfo_t, si_uid) p + wstat <- (#peek siginfo_t, si_status) p + pstat <- decipherWaitStatus wstat + return SigChldInfo { siginfoPid = pid, + siginfoUid = uid, + siginfoStatus = pstat } + _ | otherwise -> + return NoSignalSpecificInfo + return + SignalInfo { + siginfoSignal = sig, + siginfoError = Errno errno, + siginfoSpecific = extra } + +#endif /* !__PARALLEL_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- Alarms + +-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time +-- alarm at least @i@ seconds in the future. +scheduleAlarm :: Int -> IO Int +scheduleAlarm secs = do + r <- c_alarm (fromIntegral secs) + return (fromIntegral r) + +foreign import ccall unsafe "alarm" + c_alarm :: CUInt -> IO CUInt + +-- ----------------------------------------------------------------------------- +-- The NOCLDSTOP flag + +foreign import ccall "&nocldstop" nocldstop :: Ptr Int + +-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when +-- installing new signal handlers. +setStoppedChildFlag :: Bool -> IO Bool +setStoppedChildFlag b = do + rc <- peek nocldstop + poke nocldstop $ fromEnum (not b) + return (rc == (0::Int)) + +-- | Queries the current state of the stopped child flag. +queryStoppedChildFlag :: IO Bool +queryStoppedChildFlag = do + rc <- peek nocldstop + return (rc == (0::Int)) + +-- ----------------------------------------------------------------------------- +-- Manipulating signal sets + +newtype SignalSet = SignalSet (ForeignPtr CSigset) + +emptySignalSet :: SignalSet +emptySignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset) + return (SignalSet fp) + +fullSignalSet :: SignalSet +fullSignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset) + return (SignalSet fp) + +-- | A set of signals reserved for use by the implementation. In GHC, this will normally +-- include either `sigVTALRM` or `sigALRM`. +reservedSignals :: SignalSet +reservedSignals = addSignal rtsTimerSignal emptySignalSet + +foreign import ccall rtsTimerSignal :: CInt + +infixr `addSignal`, `deleteSignal` +addSignal :: Signal -> SignalSet -> SignalSet +addSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig) + return (SignalSet fp2) + +deleteSignal :: Signal -> SignalSet -> SignalSet +deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig) + return (SignalSet fp2) + +inSignalSet :: Signal -> SignalSet -> Bool +inSignalSet sig (SignalSet fp) = unsafePerformIO $ + withForeignPtr fp $ \p -> do + r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig) + return (r /= 0) + +-- | @getSignalMask@ calls @sigprocmask@ to determine the +-- set of interrupts which are currently being blocked. +getSignalMask :: IO SignalSet +getSignalMask = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p) + return (SignalSet fp) + +sigProcMask :: String -> CInt -> SignalSet -> IO () +sigProcMask fn how (SignalSet set) = + withForeignPtr set $ \p_set -> + throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr) + +-- | @setSignalMask mask@ calls @sigprocmask@ with +-- @SIG_SETMASK@ to block all interrupts in @mask@. +setSignalMask :: SignalSet -> IO () +setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set + +-- | @blockSignals mask@ calls @sigprocmask@ with +-- @SIG_BLOCK@ to add all interrupts in @mask@ to the +-- set of blocked interrupts. +blockSignals :: SignalSet -> IO () +blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set + +-- | @unblockSignals mask@ calls @sigprocmask@ with +-- @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the +-- set of blocked interrupts. +unblockSignals :: SignalSet -> IO () +unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set + +-- | @getPendingSignals@ calls @sigpending@ to obtain +-- the set of interrupts which have been received but are currently blocked. +getPendingSignals :: IO SignalSet +getPendingSignals = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p) + return (SignalSet fp) + +-- | @awaitSignal iset@ suspends execution until an interrupt is received. +-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing +-- @s@ as the new signal mask before suspending execution; otherwise, it +-- calls @sigsuspend@ with current signal mask. Note that RTS +-- scheduler signal (either 'virtualTimerExpired' or 'realTimeAlarm') +-- could cause premature termination of this call. It might be necessary to block that +-- signal before invocation of @awaitSignal@ with 'blockSignals' 'reservedSignals'. +-- +-- @awaitSignal@ returns when signal was received and processed by a +-- signal handler, or if the signal could not be caught. If you have +-- installed any signal handlers with @installHandler@, it may be wise +-- to call @yield@ directly after @awaitSignal@ to ensure that the +-- signal handler runs as promptly as possible. +awaitSignal :: Maybe SignalSet -> IO () +awaitSignal maybe_sigset = do + fp <- case maybe_sigset of + Nothing -> do SignalSet fp <- getSignalMask; return fp + Just (SignalSet fp) -> return fp + withForeignPtr fp $ \p -> do + _ <- c_sigsuspend p + return () + -- ignore the return value; according to the docs it can only ever be + -- (-1) with errno set to EINTR. + -- XXX My manpage says it can also return EFAULT. And why is ignoring + -- EINTR the right thing to do? + +foreign import ccall unsafe "sigsuspend" + c_sigsuspend :: Ptr CSigset -> IO CInt + +#if defined(darwin_HOST_OS) && __GLASGOW_HASKELL__ < 706 +-- see http://ghc.haskell.org/trac/ghc/ticket/7359#comment:3 +-- To be removed when support for GHC 7.4.x is dropped +foreign import ccall unsafe "__hscore_sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import ccall unsafe "__hscore_sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#else +foreign import capi unsafe "signal.h sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import capi unsafe "signal.h sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import capi unsafe "signal.h sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#endif + +foreign import ccall unsafe "sigpending" + c_sigpending :: Ptr CSigset -> IO CInt diff --git a/unix/System/Posix/Signals/Exts.hsc b/unix/System/Posix/Signals/Exts.hsc new file mode 100644 index 0000000..3634277 --- /dev/null +++ b/unix/System/Posix/Signals/Exts.hsc @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Signals.Exts +-- 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, includes Linuxisms/BSDisms) +-- +-- non-POSIX signal support commonly available +-- +----------------------------------------------------------------------------- + +#include "HsUnixConfig.h" +##include "HsUnixConfig.h" + +#ifdef HAVE_SIGNAL_H +#include +#endif + +module System.Posix.Signals.Exts ( + module System.Posix.Signals + , sigINFO + , sigWINCH + , infoEvent + , windowChange + ) where + +import Foreign.C +import System.Posix.Signals + +sigINFO :: CInt +sigINFO = CONST_SIGINFO + +sigWINCH :: CInt +sigWINCH = CONST_SIGWINCH + + +infoEvent :: Signal +infoEvent = sigINFO + +windowChange :: Signal +windowChange = sigWINCH diff --git a/unix/System/Posix/Temp.hsc b/unix/System/Posix/Temp.hsc new file mode 100644 index 0000000..711a696 --- /dev/null +++ b/unix/System/Posix/Temp.hsc @@ -0,0 +1,124 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Temp +-- Copyright : (c) Volker Stolz +-- Deian Stefan +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX temporary file and directory creation functions. +-- +----------------------------------------------------------------------------- + +module System.Posix.Temp ( + mkstemp, mkstemps, mkdtemp + ) where + +#include "HsUnix.h" + +import Foreign.C +import System.IO +#if !HAVE_MKDTEMP +import System.Posix.Directory (createDirectory) +#endif +import System.Posix.IO +import System.Posix.Types +import System.Posix.Internals (withFilePath, peekFilePath) + +foreign import capi unsafe "HsUnix.h mkstemp" + c_mkstemp :: CString -> IO CInt + +-- | Make a unique filename and open it for reading\/writing. The returned +-- 'FilePath' is the (possibly relative) path of the created file, which is +-- padded with 6 random characters. The argument is the desired prefix of the +-- filepath of the temporary file to be created. +-- +-- If you aren't using GHC or Hugs then this function simply wraps mktemp and +-- so shouldn't be considered safe. +mkstemp :: String -> IO (FilePath, Handle) +mkstemp template' = do + let template = template' ++ "XXXXXX" + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) + +#if HAVE_MKSTEMPS +foreign import capi unsafe "HsUnix.h mkstemps" + c_mkstemps :: CString -> CInt -> IO CInt +#endif + +-- | Make a unique filename with a given prefix and suffix and open it for +-- reading\/writing. The returned 'FilePath' is the (possibly relative) path of +-- the created file, which contains 6 random characters in between the prefix +-- and suffix. The first argument is the desired prefix of the filepath of the +-- temporary file to be created. The second argument is the suffix of the +-- temporary file to be created. +-- +-- If you are using as system that doesn't support the mkstemps glibc function +-- (supported in glibc > 2.11) then this function simply throws an error. +mkstemps :: String -> String -> IO (FilePath, Handle) +#if HAVE_MKSTEMPS +mkstemps prefix suffix = do + let template = prefix ++ "XXXXXX" ++ suffix + lenOfsuf = (fromIntegral $ length suffix) :: CInt + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) +#else +mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" +#endif + +#if HAVE_MKDTEMP +foreign import capi unsafe "HsUnix.h mkdtemp" + c_mkdtemp :: CString -> IO CString +#endif + +-- | Make a unique directory. The returned 'FilePath' is the path of the +-- created directory, which is padded with 6 random characters. The argument is +-- the desired prefix of the filepath of the temporary directory to be created. +-- +-- If you are using as system that doesn't support the mkdtemp glibc function +-- (supported in glibc > 2.1.91) then this function uses mktemp and so +-- shouldn't be considered safe. +mkdtemp :: String -> IO FilePath +mkdtemp template' = do + let template = template' ++ "XXXXXX" +#if HAVE_MKDTEMP + withFilePath template $ \ ptr -> do + _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) + name <- peekFilePath ptr + return name +#else + name <- mktemp template + h <- createDirectory name (toEnum 0o700) + return name +#endif + +#if !HAVE_MKDTEMP + +foreign import ccall unsafe "mktemp" + c_mktemp :: CString -> IO CString + +-- | Make a unique file name It is required that the template have six trailing +-- \'X\'s. This function should be considered deprecated. +{-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} +mktemp :: String -> IO String +mktemp template = do + withFilePath template $ \ ptr -> do + ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) + peekFilePath ptr +#endif + diff --git a/unix/System/Posix/Temp/ByteString.hsc b/unix/System/Posix/Temp/ByteString.hsc new file mode 100644 index 0000000..f66f847 --- /dev/null +++ b/unix/System/Posix/Temp/ByteString.hsc @@ -0,0 +1,124 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Temp.ByteString +-- Copyright : (c) Volker Stolz +-- Deian Stefan +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX temporary file and directory creation functions. +-- +----------------------------------------------------------------------------- + +module System.Posix.Temp.ByteString ( + mkstemp, mkstemps, mkdtemp + ) where + +#include "HsUnix.h" + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Foreign.C + +import System.IO +import System.Posix.ByteString.FilePath +#if !HAVE_MKDTEMP +import System.Posix.Directory (createDirectory) +#endif +import System.Posix.IO +import System.Posix.Types + +foreign import capi unsafe "HsUnix.h mkstemp" + c_mkstemp :: CString -> IO CInt + +-- | Make a unique filename and open it for reading\/writing. The returned +-- 'RawFilePath' is the (possibly relative) path of the created file, which is +-- padded with 6 random characters. The argument is the desired prefix of the +-- filepath of the temporary file to be created. +-- +-- If you aren't using GHC or Hugs then this function simply wraps mktemp and +-- so shouldn't be considered safe. +mkstemp :: ByteString -> IO (RawFilePath, Handle) +mkstemp template' = do + let template = template' `B.append` (BC.pack "XXXXXX") + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) + +#if HAVE_MKSTEMPS +foreign import capi unsafe "HsUnix.h mkstemps" + c_mkstemps :: CString -> CInt -> IO CInt +#endif + +-- |'mkstemps' - make a unique filename with a given prefix and suffix +-- and open it for reading\/writing (only safe on GHC & Hugs). +-- The returned 'RawFilePath' is the (possibly relative) path of +-- the created file, which contains 6 random characters in between +-- the prefix and suffix. +mkstemps :: ByteString -> ByteString -> IO (RawFilePath, Handle) +#if HAVE_MKSTEMPS +mkstemps prefix suffix = do + let template = prefix `B.append` (BC.pack "XXXXXX") `B.append` suffix + lenOfsuf = (fromIntegral $ B.length suffix) :: CInt + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) +#else +mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" +#endif + +#if HAVE_MKDTEMP +foreign import capi unsafe "HsUnix.h mkdtemp" + c_mkdtemp :: CString -> IO CString +#endif + +-- | Make a unique directory. The returned 'RawFilePath' is the path of the +-- created directory, which is padded with 6 random characters. The argument is +-- the desired prefix of the filepath of the temporary directory to be created. +-- +-- If you aren't using GHC or Hugs then this function simply wraps mktemp and +-- so shouldn't be considered safe. +mkdtemp :: ByteString -> IO RawFilePath +mkdtemp template' = do + let template = template' `B.append` (BC.pack "XXXXXX") +#if HAVE_MKDTEMP + withFilePath template $ \ ptr -> do + _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) + name <- peekFilePath ptr + return name +#else + name <- mktemp template + h <- createDirectory (BC.unpack name) (toEnum 0o700) + return name +#endif + +#if !HAVE_MKDTEMP + +foreign import ccall unsafe "mktemp" + c_mktemp :: CString -> IO CString + +-- | Make a unique file name It is required that the template have six trailing +-- \'X\'s. This function should be considered deprecated. +{-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} +mktemp :: ByteString -> IO RawFilePath +mktemp template = do + withFilePath template $ \ ptr -> do + ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) + peekFilePath ptr +#endif + diff --git a/unix/System/Posix/Terminal.hsc b/unix/System/Posix/Terminal.hsc new file mode 100644 index 0000000..0545f40 --- /dev/null +++ b/unix/System/Posix/Terminal.hsc @@ -0,0 +1,219 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Terminal +-- 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 Terminal support +-- +----------------------------------------------------------------------------- + +module System.Posix.Terminal ( + -- * Terminal support + + -- ** Terminal attributes + TerminalAttributes, + getTerminalAttributes, + TerminalState(..), + setTerminalAttributes, + + TerminalMode(..), + withoutMode, + withMode, + terminalMode, + bitsPerByte, + withBits, + + ControlCharacter(..), + controlChar, + withCC, + withoutCC, + + inputTime, + withTime, + minInput, + withMinInput, + + BaudRate(..), + inputSpeed, + withInputSpeed, + outputSpeed, + withOutputSpeed, + + -- ** Terminal operations + sendBreak, + drainOutput, + QueueSelector(..), + discardData, + FlowAction(..), + controlFlow, + + -- ** Process groups + getTerminalProcessGroupID, + setTerminalProcessGroupID, + + -- ** Testing a file descriptor + queryTerminal, + getTerminalName, + getControllingTerminalName, + + -- ** Pseudoterminal operations + openPseudoTerminal, + getSlaveTerminalName + ) where + +#include "HsUnix.h" + +import Foreign +import Foreign.C +import System.Posix.Terminal.Common +import System.Posix.Types +#ifndef HAVE_OPENPTY +import System.Posix.IO +#endif + +import System.Posix.Internals (peekFilePath) + +#if !HAVE_CTERMID +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated +-- with the terminal for @Fd@ @fd@. If @fd@ is associated +-- with a terminal, @getTerminalName@ returns the name of the +-- terminal. +getTerminalName :: Fd -> IO FilePath +getTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) + peekFilePath s + +foreign import ccall unsafe "ttyname" + c_ttyname :: CInt -> IO CString + +-- | @getControllingTerminalName@ calls @ctermid@ to obtain +-- a name associated with the controlling terminal for the process. If a +-- controlling terminal exists, +-- @getControllingTerminalName@ returns the name of the +-- controlling terminal. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to +-- detect availability). +getControllingTerminalName :: IO FilePath +#if HAVE_CTERMID +getControllingTerminalName = do + s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) + peekFilePath s + +foreign import capi unsafe "termios.h ctermid" + c_ctermid :: CString -> IO CString +#else +{-# WARNING getControllingTerminalName + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-} +getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName") +#endif + +-- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the +-- slave terminal associated with a pseudoterminal pair. The file +-- descriptor to pass in must be that of the master. +getSlaveTerminalName :: Fd -> IO FilePath + +#ifdef HAVE_PTSNAME +getSlaveTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) + peekFilePath s + +# if __GLASGOW_HASKELL__ < 800 +-- see comment in cbits/HsUnix.c +foreign import ccall unsafe "__hsunix_ptsname" + c_ptsname :: CInt -> IO CString +# else +foreign import capi unsafe "HsUnix.h ptsname" + c_ptsname :: CInt -> IO CString +# endif +#else +getSlaveTerminalName _ = + ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) +#endif + +-- ----------------------------------------------------------------------------- +-- openPseudoTerminal needs to be here because it depends on +-- getSlaveTerminalName. + +-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and +-- returns the newly created pair as a (@master@, @slave@) tuple. +openPseudoTerminal :: IO (Fd, Fd) + +#ifdef HAVE_OPENPTY +openPseudoTerminal = + alloca $ \p_master -> + alloca $ \p_slave -> do + throwErrnoIfMinus1_ "openPty" + (c_openpty p_master p_slave nullPtr nullPtr nullPtr) + master <- peek p_master + slave <- peek p_slave + return (Fd master, Fd slave) + +foreign import ccall unsafe "openpty" + c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a + -> IO CInt +#else +openPseudoTerminal = do + (Fd master) <- openFd "/dev/ptmx" ReadWrite Nothing + defaultFileFlags{noctty=True} + throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master) + throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master) + slaveName <- getSlaveTerminalName (Fd master) + slave <- openFd slaveName ReadWrite Nothing defaultFileFlags{noctty=True} + pushModule slave "ptem" + pushModule slave "ldterm" +# ifndef __hpux + pushModule slave "ttcompat" +# endif /* __hpux */ + return (Fd master, slave) + +-- Push a STREAMS module, for System V systems. +pushModule :: Fd -> String -> IO () +pushModule (Fd fd) name = + withCString name $ \p_name -> + throwErrnoIfMinus1_ "openPseudoTerminal" + (c_push_module fd p_name) + +foreign import ccall unsafe "__hsunix_push_module" + c_push_module :: CInt -> CString -> IO CInt + +#ifdef HAVE_PTSNAME +# if __GLASGOW_HASKELL__ < 800 +-- see comment in cbits/HsUnix.c +foreign import ccall unsafe "__hsunix_grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import ccall unsafe "__hsunix_unlockpt" + c_unlockpt :: CInt -> IO CInt +# else +foreign import capi unsafe "HsUnix.h grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import capi unsafe "HsUnix.h unlockpt" + c_unlockpt :: CInt -> IO CInt +# endif +#else +c_grantpt :: CInt -> IO CInt +c_grantpt _ = return (fromIntegral 0) + +c_unlockpt :: CInt -> IO CInt +c_unlockpt _ = return (fromIntegral 0) +#endif /* HAVE_PTSNAME */ +#endif /* !HAVE_OPENPTY */ + diff --git a/unix/System/Posix/Terminal/ByteString.hsc b/unix/System/Posix/Terminal/ByteString.hsc new file mode 100644 index 0000000..cd6e200 --- /dev/null +++ b/unix/System/Posix/Terminal/ByteString.hsc @@ -0,0 +1,226 @@ +{-# LANGUAGE CApiFFI #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Terminal.ByteString +-- 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 Terminal support +-- +----------------------------------------------------------------------------- + +module System.Posix.Terminal.ByteString ( + -- * Terminal support + + -- ** Terminal attributes + TerminalAttributes, + getTerminalAttributes, + TerminalState(..), + setTerminalAttributes, + + TerminalMode(..), + withoutMode, + withMode, + terminalMode, + bitsPerByte, + withBits, + + ControlCharacter(..), + controlChar, + withCC, + withoutCC, + + inputTime, + withTime, + minInput, + withMinInput, + + BaudRate(..), + inputSpeed, + withInputSpeed, + outputSpeed, + withOutputSpeed, + + -- ** Terminal operations + sendBreak, + drainOutput, + QueueSelector(..), + discardData, + FlowAction(..), + controlFlow, + + -- ** Process groups + getTerminalProcessGroupID, + setTerminalProcessGroupID, + + -- ** Testing a file descriptor + queryTerminal, + getTerminalName, + getControllingTerminalName, + + -- ** Pseudoterminal operations + openPseudoTerminal, + getSlaveTerminalName + ) where + +#include "HsUnix.h" + +import Foreign +import System.Posix.Types +import System.Posix.Terminal.Common +#ifndef HAVE_OPENPTY +import System.Posix.IO.ByteString (defaultFileFlags, openFd, noctty, OpenMode(ReadWrite)) +import Data.ByteString.Char8 as B ( pack, ) +#endif + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.Posix.ByteString.FilePath + +#if !HAVE_CTERMID +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated +-- with the terminal for @Fd@ @fd@. If @fd@ is associated +-- with a terminal, @getTerminalName@ returns the name of the +-- terminal. +getTerminalName :: Fd -> IO RawFilePath +getTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) + peekFilePath s + +foreign import ccall unsafe "ttyname" + c_ttyname :: CInt -> IO CString + +-- | @getControllingTerminalName@ calls @ctermid@ to obtain +-- a name associated with the controlling terminal for the process. If a +-- controlling terminal exists, +-- @getControllingTerminalName@ returns the name of the +-- controlling terminal. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to +-- detect availability). +getControllingTerminalName :: IO RawFilePath +#if HAVE_CTERMID +getControllingTerminalName = do + s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) + peekFilePath s + +foreign import capi unsafe "termios.h ctermid" + c_ctermid :: CString -> IO CString +#else +{-# WARNING getControllingTerminalName + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-} +getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName") +#endif + +-- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the +-- slave terminal associated with a pseudoterminal pair. The file +-- descriptor to pass in must be that of the master. +getSlaveTerminalName :: Fd -> IO RawFilePath + +#ifdef HAVE_PTSNAME +getSlaveTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) + peekFilePath s + +# if __GLASGOW_HASKELL__ < 800 +-- see comment in cbits/HsUnix.c +foreign import ccall unsafe "__hsunix_ptsname" + c_ptsname :: CInt -> IO CString +# else +foreign import capi unsafe "HsUnix.h ptsname" + c_ptsname :: CInt -> IO CString +# endif +#else +getSlaveTerminalName _ = + ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) +#endif + +-- ----------------------------------------------------------------------------- +-- openPseudoTerminal needs to be here because it depends on +-- getSlaveTerminalName. + +-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and +-- returns the newly created pair as a (@master@, @slave@) tuple. +openPseudoTerminal :: IO (Fd, Fd) + +#ifdef HAVE_OPENPTY +openPseudoTerminal = + alloca $ \p_master -> + alloca $ \p_slave -> do + throwErrnoIfMinus1_ "openPty" + (c_openpty p_master p_slave nullPtr nullPtr nullPtr) + master <- peek p_master + slave <- peek p_slave + return (Fd master, Fd slave) + +foreign import ccall unsafe "openpty" + c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a + -> IO CInt +#else +openPseudoTerminal = do + (Fd master) <- openFd (B.pack "/dev/ptmx") ReadWrite Nothing + defaultFileFlags{noctty=True} + throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master) + throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master) + slaveName <- getSlaveTerminalName (Fd master) + slave <- openFd slaveName ReadWrite Nothing defaultFileFlags{noctty=True} + pushModule slave "ptem" + pushModule slave "ldterm" +# ifndef __hpux + pushModule slave "ttcompat" +# endif /* __hpux */ + return (Fd master, slave) + +-- Push a STREAMS module, for System V systems. +pushModule :: Fd -> String -> IO () +pushModule (Fd fd) name = + withCString name $ \p_name -> + throwErrnoIfMinus1_ "openPseudoTerminal" + (c_push_module fd p_name) + +foreign import ccall unsafe "__hsunix_push_module" + c_push_module :: CInt -> CString -> IO CInt + +#if HAVE_PTSNAME +# if __GLASGOW_HASKELL__ < 800 +-- see comment in cbits/HsUnix.c +foreign import ccall unsafe "__hsunix_grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import ccall unsafe "__hsunix_unlockpt" + c_unlockpt :: CInt -> IO CInt +# else +foreign import capi unsafe "HsUnix.h grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import capi unsafe "HsUnix.h unlockpt" + c_unlockpt :: CInt -> IO CInt +# endif +#else +c_grantpt :: CInt -> IO CInt +c_grantpt _ = return (fromIntegral (0::Int)) + +c_unlockpt :: CInt -> IO CInt +c_unlockpt _ = return (fromIntegral (0::Int)) +#endif /* HAVE_PTSNAME */ +#endif /* !HAVE_OPENPTY */ diff --git a/unix/System/Posix/Terminal/Common.hsc b/unix/System/Posix/Terminal/Common.hsc new file mode 100644 index 0000000..3dc16e2 --- /dev/null +++ b/unix/System/Posix/Terminal/Common.hsc @@ -0,0 +1,881 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Terminal.Common +-- 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 Terminal support +-- +----------------------------------------------------------------------------- + +-- see https://android.googlesource.com/platform/bionic/+/9ae59c0/libc/bionic/pathconf.c#37 +#if !defined(_POSIX_VDISABLE) && defined(__ANDROID__) +#define _POSIX_VDISABLE -1 +#endif + + +module System.Posix.Terminal.Common ( + -- * Terminal support + + -- ** Terminal attributes + TerminalAttributes, + getTerminalAttributes, + TerminalState(..), + setTerminalAttributes, + + CTermios, + TerminalMode(..), + withoutMode, + withMode, + terminalMode, + bitsPerByte, + withBits, + + ControlCharacter(..), + controlChar, + withCC, + withoutCC, + + inputTime, + withTime, + minInput, + withMinInput, + + BaudRate(..), + inputSpeed, + withInputSpeed, + outputSpeed, + withOutputSpeed, + + -- ** Terminal operations + sendBreak, + drainOutput, + QueueSelector(..), + discardData, + FlowAction(..), + controlFlow, + + -- ** Process groups + getTerminalProcessGroupID, + setTerminalProcessGroupID, + + -- ** Testing a file descriptor + queryTerminal, + ) where + +#include "HsUnix.h" + +import Data.Bits +import Data.Char +import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ ) +import Foreign.C.Types +import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes ) +import Foreign.Marshal.Utils ( copyBytes ) +import Foreign.Ptr ( Ptr, plusPtr ) +import Foreign.Storable ( Storable(..) ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Posix.Types +import System.Posix.Internals ( CTermios ) + +#if !HAVE_TCDRAIN +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- ----------------------------------------------------------------------------- +-- Terminal attributes + +newtype TerminalAttributes = TerminalAttributes (ForeignPtr CTermios) + +makeTerminalAttributes :: ForeignPtr CTermios -> TerminalAttributes +makeTerminalAttributes = TerminalAttributes + +withTerminalAttributes :: TerminalAttributes -> (Ptr CTermios -> IO a) -> IO a +withTerminalAttributes (TerminalAttributes termios) = withForeignPtr termios + + +data TerminalMode + -- input flags + = InterruptOnBreak -- ^ @BRKINT@ - Signal interrupt on break + | MapCRtoLF -- ^ @ICRNL@ - Map CR to NL on input + | IgnoreBreak -- ^ @IGNBRK@ - Ignore break condition + | IgnoreCR -- ^ @IGNCR@ - Ignore CR + | IgnoreParityErrors -- ^ @IGNPAR@ - Ignore characters with parity errors + | MapLFtoCR -- ^ @INLCR@ - Map NL to CR on input + | CheckParity -- ^ @INPCK@ - Enable input parity check + | StripHighBit -- ^ @ISTRIP@ - Strip character + | RestartOnAny -- ^ @IXANY@ - Enable any character to restart output + | StartStopInput -- ^ @IXOFF@ - Enable start/stop input control + | StartStopOutput -- ^ @IXON@ - Enable start/stop output control + | MarkParityErrors -- ^ @PARMRK@ - Mark parity errors + + -- output flags + | ProcessOutput -- ^ @OPOST@ - Post-process output + | MapLFtoCRLF -- ^ @ONLCR@ - (XSI) Map NL to CR-NL on output + -- + -- @since 2.8.0.0 + | OutputMapCRtoLF -- ^ @OCRNL@ - (XSI) Map CR to NL on output + -- + -- @since 2.8.0.0 + | NoCRAtColumnZero -- ^ @ONOCR@ - (XSI) No CR output at column 0 + -- + -- @since 2.8.0.0 + | ReturnMeansLF -- ^ @ONLRET@ - (XSI) NL performs CR function + -- + -- @since 2.8.0.0 + | TabDelayMask0 -- ^ @TABDLY(TAB0)@ - (XSI) Select horizontal-tab delays: type 0 + -- + -- @since 2.8.0.0 + | TabDelayMask3 -- ^ @TABDLY(TAB3)@ - (XSI) Select horizontal-tab delays: type 3 + -- + -- @since 2.8.0.0 + + -- control flags + | LocalMode -- ^ @CLOCAL@ - Ignore modem status lines + | ReadEnable -- ^ @CREAD@ - Enable receiver + | TwoStopBits -- ^ @CSTOPB@ - Send two stop bits, else one + | HangupOnClose -- ^ @HUPCL@ - Hang up on last close + | EnableParity -- ^ @PARENB@ - Parity enable + | OddParity -- ^ @PARODD@ - Odd parity, else even + + -- local modes + | EnableEcho -- ^ @ECHO@ - Enable echo + | EchoErase -- ^ @ECHOE@ - Echo erase character as error-correcting backspace + | EchoKill -- ^ @ECHOK@ - Echo KILL + | EchoLF -- ^ @ECHONL@ - Echo NL + | ProcessInput -- ^ @ICANON@ - Canonical input (erase and kill processing) + | ExtendedFunctions -- ^ @IEXTEN@ - Enable extended input character processing + | KeyboardInterrupts -- ^ @ISIG@ - Enable signals + | NoFlushOnInterrupt -- ^ @NOFLSH@ - Disable flush after interrupt or quit + | BackgroundWriteInterrupt -- ^ @TOSTOP@ - Send @SIGTTOU@ for background output + +withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes +withoutMode termios InterruptOnBreak = clearInputFlag (#const BRKINT) termios +withoutMode termios MapCRtoLF = clearInputFlag (#const ICRNL) termios +withoutMode termios IgnoreBreak = clearInputFlag (#const IGNBRK) termios +withoutMode termios IgnoreCR = clearInputFlag (#const IGNCR) termios +withoutMode termios IgnoreParityErrors = clearInputFlag (#const IGNPAR) termios +withoutMode termios MapLFtoCR = clearInputFlag (#const INLCR) termios +withoutMode termios CheckParity = clearInputFlag (#const INPCK) termios +withoutMode termios StripHighBit = clearInputFlag (#const ISTRIP) termios +withoutMode termios RestartOnAny = clearInputFlag (#const IXANY) termios +withoutMode termios StartStopInput = clearInputFlag (#const IXOFF) termios +withoutMode termios StartStopOutput = clearInputFlag (#const IXON) termios +withoutMode termios MarkParityErrors = clearInputFlag (#const PARMRK) termios +withoutMode termios ProcessOutput = clearOutputFlag (#const OPOST) termios +withoutMode termios MapLFtoCRLF = clearOutputFlag (#const ONLCR) termios +withoutMode termios OutputMapCRtoLF = clearOutputFlag (#const OCRNL) termios +withoutMode termios NoCRAtColumnZero = clearOutputFlag (#const ONOCR) termios +withoutMode termios ReturnMeansLF = clearOutputFlag (#const ONLRET) termios +withoutMode termios TabDelayMask0 = clearOutputFlag (#const TAB0) termios +withoutMode termios TabDelayMask3 = clearOutputFlag (#const TAB3) termios +withoutMode termios LocalMode = clearControlFlag (#const CLOCAL) termios +withoutMode termios ReadEnable = clearControlFlag (#const CREAD) termios +withoutMode termios TwoStopBits = clearControlFlag (#const CSTOPB) termios +withoutMode termios HangupOnClose = clearControlFlag (#const HUPCL) termios +withoutMode termios EnableParity = clearControlFlag (#const PARENB) termios +withoutMode termios OddParity = clearControlFlag (#const PARODD) termios +withoutMode termios EnableEcho = clearLocalFlag (#const ECHO) termios +withoutMode termios EchoErase = clearLocalFlag (#const ECHOE) termios +withoutMode termios EchoKill = clearLocalFlag (#const ECHOK) termios +withoutMode termios EchoLF = clearLocalFlag (#const ECHONL) termios +withoutMode termios ProcessInput = clearLocalFlag (#const ICANON) termios +withoutMode termios ExtendedFunctions = clearLocalFlag (#const IEXTEN) termios +withoutMode termios KeyboardInterrupts = clearLocalFlag (#const ISIG) termios +withoutMode termios NoFlushOnInterrupt = setLocalFlag (#const NOFLSH) termios +withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (#const TOSTOP) termios + +withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes +withMode termios InterruptOnBreak = setInputFlag (#const BRKINT) termios +withMode termios MapCRtoLF = setInputFlag (#const ICRNL) termios +withMode termios IgnoreBreak = setInputFlag (#const IGNBRK) termios +withMode termios IgnoreCR = setInputFlag (#const IGNCR) termios +withMode termios IgnoreParityErrors = setInputFlag (#const IGNPAR) termios +withMode termios MapLFtoCR = setInputFlag (#const INLCR) termios +withMode termios CheckParity = setInputFlag (#const INPCK) termios +withMode termios StripHighBit = setInputFlag (#const ISTRIP) termios +withMode termios RestartOnAny = setInputFlag (#const IXANY) termios +withMode termios StartStopInput = setInputFlag (#const IXOFF) termios +withMode termios StartStopOutput = setInputFlag (#const IXON) termios +withMode termios MarkParityErrors = setInputFlag (#const PARMRK) termios +withMode termios ProcessOutput = setOutputFlag (#const OPOST) termios +withMode termios MapLFtoCRLF = setOutputFlag (#const ONLCR) termios +withMode termios OutputMapCRtoLF = setOutputFlag (#const OCRNL) termios +withMode termios NoCRAtColumnZero = setOutputFlag (#const ONOCR) termios +withMode termios ReturnMeansLF = setOutputFlag (#const ONLRET) termios +withMode termios TabDelayMask0 = setOutputFlag (#const TAB0) termios +withMode termios TabDelayMask3 = setOutputFlag (#const TAB3) termios +withMode termios LocalMode = setControlFlag (#const CLOCAL) termios +withMode termios ReadEnable = setControlFlag (#const CREAD) termios +withMode termios TwoStopBits = setControlFlag (#const CSTOPB) termios +withMode termios HangupOnClose = setControlFlag (#const HUPCL) termios +withMode termios EnableParity = setControlFlag (#const PARENB) termios +withMode termios OddParity = setControlFlag (#const PARODD) termios +withMode termios EnableEcho = setLocalFlag (#const ECHO) termios +withMode termios EchoErase = setLocalFlag (#const ECHOE) termios +withMode termios EchoKill = setLocalFlag (#const ECHOK) termios +withMode termios EchoLF = setLocalFlag (#const ECHONL) termios +withMode termios ProcessInput = setLocalFlag (#const ICANON) termios +withMode termios ExtendedFunctions = setLocalFlag (#const IEXTEN) termios +withMode termios KeyboardInterrupts = setLocalFlag (#const ISIG) termios +withMode termios NoFlushOnInterrupt = clearLocalFlag (#const NOFLSH) termios +withMode termios BackgroundWriteInterrupt = setLocalFlag (#const TOSTOP) termios + +terminalMode :: TerminalMode -> TerminalAttributes -> Bool +terminalMode InterruptOnBreak = testInputFlag (#const BRKINT) +terminalMode MapCRtoLF = testInputFlag (#const ICRNL) +terminalMode IgnoreBreak = testInputFlag (#const IGNBRK) +terminalMode IgnoreCR = testInputFlag (#const IGNCR) +terminalMode IgnoreParityErrors = testInputFlag (#const IGNPAR) +terminalMode MapLFtoCR = testInputFlag (#const INLCR) +terminalMode CheckParity = testInputFlag (#const INPCK) +terminalMode StripHighBit = testInputFlag (#const ISTRIP) +terminalMode RestartOnAny = testInputFlag (#const IXANY) +terminalMode StartStopInput = testInputFlag (#const IXOFF) +terminalMode StartStopOutput = testInputFlag (#const IXON) +terminalMode MarkParityErrors = testInputFlag (#const PARMRK) +terminalMode ProcessOutput = testOutputFlag (#const OPOST) +terminalMode MapLFtoCRLF = testOutputFlag (#const ONLCR) +terminalMode OutputMapCRtoLF = testOutputFlag (#const OCRNL) +terminalMode NoCRAtColumnZero = testOutputFlag (#const ONOCR) +terminalMode ReturnMeansLF = testOutputFlag (#const ONLRET) +terminalMode TabDelayMask0 = testOutputFlag (#const TAB0) +terminalMode TabDelayMask3 = testOutputFlag (#const TAB3) +terminalMode LocalMode = testControlFlag (#const CLOCAL) +terminalMode ReadEnable = testControlFlag (#const CREAD) +terminalMode TwoStopBits = testControlFlag (#const CSTOPB) +terminalMode HangupOnClose = testControlFlag (#const HUPCL) +terminalMode EnableParity = testControlFlag (#const PARENB) +terminalMode OddParity = testControlFlag (#const PARODD) +terminalMode EnableEcho = testLocalFlag (#const ECHO) +terminalMode EchoErase = testLocalFlag (#const ECHOE) +terminalMode EchoKill = testLocalFlag (#const ECHOK) +terminalMode EchoLF = testLocalFlag (#const ECHONL) +terminalMode ProcessInput = testLocalFlag (#const ICANON) +terminalMode ExtendedFunctions = testLocalFlag (#const IEXTEN) +terminalMode KeyboardInterrupts = testLocalFlag (#const ISIG) +terminalMode NoFlushOnInterrupt = not . testLocalFlag (#const NOFLSH) +terminalMode BackgroundWriteInterrupt = testLocalFlag (#const TOSTOP) + +bitsPerByte :: TerminalAttributes -> Int +bitsPerByte termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + return $! (word2Bits (cflag .&. (#const CSIZE))) + where + word2Bits :: CTcflag -> Int + word2Bits x = + if x == (#const CS5) then 5 + else if x == (#const CS6) then 6 + else if x == (#const CS7) then 7 + else if x == (#const CS8) then 8 + else 0 + +withBits :: TerminalAttributes -> Int -> TerminalAttributes +withBits termios bits = unsafePerformIO $ do + withNewTermios termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + (#poke struct termios, c_cflag) p + ((cflag .&. complement (#const CSIZE)) .|. mask bits) + where + mask :: Int -> CTcflag + mask 5 = (#const CS5) + mask 6 = (#const CS6) + mask 7 = (#const CS7) + mask 8 = (#const CS8) + mask _ = error "withBits bit value out of range [5..8]" + +data ControlCharacter + = EndOfFile -- VEOF + | EndOfLine -- VEOL + | Erase -- VERASE + | Interrupt -- VINTR + | Kill -- VKILL + | Quit -- VQUIT + | Start -- VSTART + | Stop -- VSTOP + | Suspend -- VSUSP + +controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char +controlChar termios cc = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + val <- peekElemOff c_cc (cc2Word cc) + if val == ((#const _POSIX_VDISABLE)::CCc) + then return Nothing + else return (Just (chr (fromEnum val))) + +withCC :: TerminalAttributes + -> (ControlCharacter, Char) + -> TerminalAttributes +withCC termios (cc, c) = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc) + +withoutCC :: TerminalAttributes + -> ControlCharacter + -> TerminalAttributes +withoutCC termios cc = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (cc2Word cc) ((#const _POSIX_VDISABLE) :: CCc) + +inputTime :: TerminalAttributes -> Int +inputTime termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VTIME) + return (fromEnum (c :: CCc)) + +withTime :: TerminalAttributes -> Int -> TerminalAttributes +withTime termios time = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (#const VTIME) (fromIntegral time :: CCc) + +minInput :: TerminalAttributes -> Int +minInput termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VMIN) + return (fromEnum (c :: CCc)) + +withMinInput :: TerminalAttributes -> Int -> TerminalAttributes +withMinInput termios count = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (#const VMIN) (fromIntegral count :: CCc) + +data BaudRate + -- These are the standard rates stipulated by POSIX: + = B0 + | B50 + | B75 + | B110 + | B134 + | B150 + | B200 + | B300 + | B600 + | B1200 + | B1800 + | B2400 + | B4800 + | B9600 + | B19200 + | B38400 + -- These are non-standard rates that are often present on modern Unixes: + | B57600 + | B115200 + | B230400 + | B460800 + | B500000 + | B576000 + | B921600 + | B1000000 + | B1152000 + | B1500000 + | B2000000 + | B2500000 + | B3000000 + | B3500000 + | B4000000 + +inputSpeed :: TerminalAttributes -> BaudRate +inputSpeed termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + w <- c_cfgetispeed p + return (word2Baud w) + +foreign import capi unsafe "termios.h cfgetispeed" + c_cfgetispeed :: Ptr CTermios -> IO CSpeed + +withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes +withInputSpeed termios br = unsafePerformIO $ do + withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br) + +foreign import capi unsafe "termios.h cfsetispeed" + c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt + + +outputSpeed :: TerminalAttributes -> BaudRate +outputSpeed termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + w <- c_cfgetospeed p + return (word2Baud w) + +foreign import capi unsafe "termios.h cfgetospeed" + c_cfgetospeed :: Ptr CTermios -> IO CSpeed + +withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes +withOutputSpeed termios br = unsafePerformIO $ do + withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br) + +foreign import capi unsafe "termios.h cfsetospeed" + c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt + +-- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain +-- the @TerminalAttributes@ associated with @Fd@ @fd@. +getTerminalAttributes :: Fd -> IO TerminalAttributes +getTerminalAttributes (Fd fd) = do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p) + return $ makeTerminalAttributes fp + +foreign import capi unsafe "termios.h tcgetattr" + c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt + +data TerminalState + = Immediately + | WhenDrained + | WhenFlushed + +-- | @setTerminalAttributes fd attr ts@ calls @tcsetattr@ to change +-- the @TerminalAttributes@ associated with @Fd@ @fd@ to +-- @attr@, when the terminal is in the state indicated by @ts@. +setTerminalAttributes :: Fd + -> TerminalAttributes + -> TerminalState + -> IO () +setTerminalAttributes (Fd fd) termios state = do + withTerminalAttributes termios $ \p -> + throwErrnoIfMinus1_ "setTerminalAttributes" + (c_tcsetattr fd (state2Int state) p) + where + state2Int :: TerminalState -> CInt + state2Int Immediately = (#const TCSANOW) + state2Int WhenDrained = (#const TCSADRAIN) + state2Int WhenFlushed = (#const TCSAFLUSH) + +foreign import capi unsafe "termios.h tcsetattr" + c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt + +-- | @sendBreak fd duration@ calls @tcsendbreak@ to transmit a +-- continuous stream of zero-valued bits on @Fd@ @fd@ for the +-- specified implementation-dependent @duration@. +sendBreak :: Fd -> Int -> IO () +sendBreak (Fd fd) duration + = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration)) + +foreign import capi unsafe "termios.h tcsendbreak" + c_tcsendbreak :: CInt -> CInt -> IO CInt + +-- | @drainOutput fd@ calls @tcdrain@ to block until all output +-- written to @Fd@ @fd@ has been transmitted. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @tcdrain(3)@ (use @#if HAVE_TCDRAIN@ CPP guard to +-- detect availability). +drainOutput :: Fd -> IO () +#if HAVE_TCDRAIN +drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd) + +foreign import capi safe "termios.h tcdrain" + c_tcdrain :: CInt -> IO CInt +#else +{-# WARNING drainOutput + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_TCDRAIN@)" #-} +drainOutput _ = ioError (ioeSetLocation unsupportedOperation "drainOutput") +#endif + +data QueueSelector + = InputQueue -- TCIFLUSH + | OutputQueue -- TCOFLUSH + | BothQueues -- TCIOFLUSH + +-- | @discardData fd queues@ calls @tcflush@ to discard +-- pending input and\/or output for @Fd@ @fd@, +-- as indicated by the @QueueSelector@ @queues@. +discardData :: Fd -> QueueSelector -> IO () +discardData (Fd fd) queue = + throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue)) + where + queue2Int :: QueueSelector -> CInt + queue2Int InputQueue = (#const TCIFLUSH) + queue2Int OutputQueue = (#const TCOFLUSH) + queue2Int BothQueues = (#const TCIOFLUSH) + +foreign import capi unsafe "termios.h tcflush" + c_tcflush :: CInt -> CInt -> IO CInt + +data FlowAction + = SuspendOutput -- ^ TCOOFF + | RestartOutput -- ^ TCOON + | TransmitStop -- ^ TCIOFF + | TransmitStart -- ^ TCION + +-- | @controlFlow fd action@ calls @tcflow@ to control the +-- flow of data on @Fd@ @fd@, as indicated by +-- @action@. +controlFlow :: Fd -> FlowAction -> IO () +controlFlow (Fd fd) action = + throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action)) + where + action2Int :: FlowAction -> CInt + action2Int SuspendOutput = (#const TCOOFF) + action2Int RestartOutput = (#const TCOON) + action2Int TransmitStop = (#const TCIOFF) + action2Int TransmitStart = (#const TCION) + +foreign import capi unsafe "termios.h tcflow" + c_tcflow :: CInt -> CInt -> IO CInt + +-- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to +-- obtain the @ProcessGroupID@ of the foreground process group +-- associated with the terminal attached to @Fd@ @fd@. +getTerminalProcessGroupID :: Fd -> IO ProcessGroupID +getTerminalProcessGroupID (Fd fd) = do + throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd) + +foreign import ccall unsafe "tcgetpgrp" + c_tcgetpgrp :: CInt -> IO CPid + +-- | @setTerminalProcessGroupID fd pgid@ calls @tcsetpgrp@ to +-- set the @ProcessGroupID@ of the foreground process group +-- associated with the terminal attached to @Fd@ +-- @fd@ to @pgid@. +setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO () +setTerminalProcessGroupID (Fd fd) pgid = + throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid) + +foreign import ccall unsafe "tcsetpgrp" + c_tcsetpgrp :: CInt -> CPid -> IO CInt + +-- ----------------------------------------------------------------------------- +-- file descriptor queries + +-- | @queryTerminal fd@ calls @isatty@ to determine whether or +-- not @Fd@ @fd@ is associated with a terminal. +queryTerminal :: Fd -> IO Bool +queryTerminal (Fd fd) = do + r <- c_isatty fd + return (r == 1) + -- ToDo: the spec says that it can set errno to EBADF if the result is zero + +foreign import ccall unsafe "isatty" + c_isatty :: CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Local utility functions + +-- Convert Haskell ControlCharacter to Int + +cc2Word :: ControlCharacter -> Int +cc2Word EndOfFile = (#const VEOF) +cc2Word EndOfLine = (#const VEOL) +cc2Word Erase = (#const VERASE) +cc2Word Interrupt = (#const VINTR) +cc2Word Kill = (#const VKILL) +cc2Word Quit = (#const VQUIT) +cc2Word Suspend = (#const VSUSP) +cc2Word Start = (#const VSTART) +cc2Word Stop = (#const VSTOP) + +-- Convert Haskell BaudRate to unsigned integral type (Word) + +baud2Word :: BaudRate -> CSpeed +baud2Word B0 = (#const B0) +baud2Word B50 = (#const B50) +baud2Word B75 = (#const B75) +baud2Word B110 = (#const B110) +baud2Word B134 = (#const B134) +baud2Word B150 = (#const B150) +baud2Word B200 = (#const B200) +baud2Word B300 = (#const B300) +baud2Word B600 = (#const B600) +baud2Word B1200 = (#const B1200) +baud2Word B1800 = (#const B1800) +baud2Word B2400 = (#const B2400) +baud2Word B4800 = (#const B4800) +baud2Word B9600 = (#const B9600) +baud2Word B19200 = (#const B19200) +baud2Word B38400 = (#const B38400) +#ifdef B57600 +baud2Word B57600 = (#const B57600) +#else +baud2Word B57600 = error "B57600 not available on this system" +#endif +#ifdef B115200 +baud2Word B115200 = (#const B115200) +#else +baud2Word B115200 = error "B115200 not available on this system" +#endif +#ifdef B230400 +baud2Word B230400 = (#const B230400) +#else +baud2Word B230400 = error "B230400 not available on this system" +#endif +#ifdef B460800 +baud2Word B460800 = (#const B460800) +#else +baud2Word B460800 = error "B460800 not available on this system" +#endif +#ifdef B500000 +baud2Word B500000 = (#const B500000) +#else +baud2Word B500000 = error "B500000 not available on this system" +#endif +#ifdef B576000 +baud2Word B576000 = (#const B576000) +#else +baud2Word B576000 = error "B576000 not available on this system" +#endif +#ifdef B921600 +baud2Word B921600 = (#const B921600) +#else +baud2Word B921600 = error "B921600 not available on this system" +#endif +#ifdef B1000000 +baud2Word B1000000 = (#const B1000000) +#else +baud2Word B1000000 = error "B1000000 not available on this system" +#endif +#ifdef B1152000 +baud2Word B1152000 = (#const B1152000) +#else +baud2Word B1152000 = error "B1152000 not available on this system" +#endif +#ifdef B1500000 +baud2Word B1500000 = (#const B1500000) +#else +baud2Word B1500000 = error "B1500000 not available on this system" +#endif +#ifdef B2000000 +baud2Word B2000000 = (#const B2000000) +#else +baud2Word B2000000 = error "B2000000 not available on this system" +#endif +#ifdef B2500000 +baud2Word B2500000 = (#const B2500000) +#else +baud2Word B2500000 = error "B2500000 not available on this system" +#endif +#ifdef B3000000 +baud2Word B3000000 = (#const B3000000) +#else +baud2Word B3000000 = error "B3000000 not available on this system" +#endif +#ifdef B3500000 +baud2Word B3500000 = (#const B3500000) +#else +baud2Word B3500000 = error "B3500000 not available on this system" +#endif +#ifdef B4000000 +baud2Word B4000000 = (#const B4000000) +#else +baud2Word B4000000 = error "B4000000 not available on this system" +#endif + +-- And convert a word back to a baud rate +-- We really need some cpp macros here. + +word2Baud :: CSpeed -> BaudRate +word2Baud x = case x of + (#const B0) -> B0 + (#const B50) -> B50 + (#const B75) -> B75 + (#const B110) -> B110 + (#const B134) -> B134 + (#const B150) -> B150 + (#const B200) -> B200 + (#const B300) -> B300 + (#const B600) -> B600 + (#const B1200) -> B1200 + (#const B1800) -> B1800 + (#const B2400) -> B2400 + (#const B4800) -> B4800 + (#const B9600) -> B9600 + (#const B19200) -> B19200 + (#const B38400) -> B38400 +#ifdef B57600 + (#const B57600) -> B57600 +#endif +#ifdef B115200 + (#const B115200) -> B115200 +#endif +#ifdef B230400 + (#const B230400) -> B230400 +#endif +#ifdef B460800 + (#const B460800) -> B460800 +#endif +#ifdef B500000 + (#const B500000) -> B500000 +#endif +#ifdef B576000 + (#const B576000) -> B576000 +#endif +#ifdef B921600 + (#const B921600) -> B921600 +#endif +#ifdef B1000000 + (#const B1000000) -> B1000000 +#endif +#ifdef B1152000 + (#const B1152000) -> B1152000 +#endif +#ifdef B1500000 + (#const B1500000) -> B1500000 +#endif +#ifdef B2000000 + (#const B2000000) -> B2000000 +#endif +#ifdef B2500000 + (#const B2500000) -> B2500000 +#endif +#ifdef B3000000 + (#const B3000000) -> B3000000 +#endif +#ifdef B3500000 + (#const B3500000) -> B3500000 +#endif +#ifdef B4000000 + (#const B4000000) -> B4000000 +#endif + _ -> error "unknown baud rate" + +-- Clear termios i_flag + +clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearInputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + iflag <- (#peek struct termios, c_iflag) p2 + (#poke struct termios, c_iflag) p1 (iflag .&. complement flag) + return $ makeTerminalAttributes fp + +-- Set termios i_flag + +setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setInputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + iflag <- (#peek struct termios, c_iflag) p2 + (#poke struct termios, c_iflag) p1 (iflag .|. flag) + return $ makeTerminalAttributes fp + +-- Examine termios i_flag + +testInputFlag :: CTcflag -> TerminalAttributes -> Bool +testInputFlag flag termios = unsafePerformIO $ + withTerminalAttributes termios $ \p -> do + iflag <- (#peek struct termios, c_iflag) p + return $! ((iflag .&. flag) /= 0) + +-- Clear termios c_flag + +clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearControlFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + cflag <- (#peek struct termios, c_cflag) p2 + (#poke struct termios, c_cflag) p1 (cflag .&. complement flag) + return $ makeTerminalAttributes fp + +-- Set termios c_flag + +setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setControlFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + cflag <- (#peek struct termios, c_cflag) p2 + (#poke struct termios, c_cflag) p1 (cflag .|. flag) + return $ makeTerminalAttributes fp + +-- Examine termios c_flag + +testControlFlag :: CTcflag -> TerminalAttributes -> Bool +testControlFlag flag termios = unsafePerformIO $ + withTerminalAttributes termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + return $! ((cflag .&. flag) /= 0) + +-- Clear termios l_flag + +clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearLocalFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + lflag <- (#peek struct termios, c_lflag) p2 + (#poke struct termios, c_lflag) p1 (lflag .&. complement flag) + return $ makeTerminalAttributes fp + +-- Set termios l_flag + +setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setLocalFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + lflag <- (#peek struct termios, c_lflag) p2 + (#poke struct termios, c_lflag) p1 (lflag .|. flag) + return $ makeTerminalAttributes fp + +-- Examine termios l_flag + +testLocalFlag :: CTcflag -> TerminalAttributes -> Bool +testLocalFlag flag termios = unsafePerformIO $ + withTerminalAttributes termios $ \p -> do + lflag <- (#peek struct termios, c_lflag) p + return $! ((lflag .&. flag) /= 0) + +-- Clear termios o_flag + +clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearOutputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + oflag <- (#peek struct termios, c_oflag) p2 + (#poke struct termios, c_oflag) p1 (oflag .&. complement flag) + return $ makeTerminalAttributes fp + +-- Set termios o_flag + +setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setOutputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + oflag <- (#peek struct termios, c_oflag) p2 + (#poke struct termios, c_oflag) p1 (oflag .|. flag) + return $ makeTerminalAttributes fp + +-- Examine termios o_flag + +testOutputFlag :: CTcflag -> TerminalAttributes -> Bool +testOutputFlag flag termios = unsafePerformIO $ + withTerminalAttributes termios $ \p -> do + oflag <- (#peek struct termios, c_oflag) p + return $! ((oflag .&. flag) /= 0) + +withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a) + -> IO TerminalAttributes +withNewTermios termios action = do + fp1 <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp1 $ \p1 -> do + withTerminalAttributes termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + _ <- action p1 + return () + return $ makeTerminalAttributes fp1 diff --git a/unix/System/Posix/Time.hs b/unix/System/Posix/Time.hs new file mode 100644 index 0000000..b6ed885 --- /dev/null +++ b/unix/System/Posix/Time.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Time +-- 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 Time support +-- +----------------------------------------------------------------------------- + +module System.Posix.Time ( + epochTime, + -- ToDo: lots more from sys/time.h + -- how much already supported by System.Time? + ) where + +import System.Posix.Types +import Foreign +import Foreign.C + +-- ----------------------------------------------------------------------------- +-- epochTime + +-- | @epochTime@ calls @time@ to obtain the number of +-- seconds that have elapsed since the epoch (Jan 01 00:00:00 GMT 1970). +epochTime :: IO EpochTime +epochTime = throwErrnoIfMinus1 "epochTime" (c_time nullPtr) + +foreign import capi unsafe "HsUnix.h time" + c_time :: Ptr CTime -> IO CTime diff --git a/unix/System/Posix/Unistd.hsc b/unix/System/Posix/Unistd.hsc new file mode 100644 index 0000000..ec02216 --- /dev/null +++ b/unix/System/Posix/Unistd.hsc @@ -0,0 +1,264 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE NondecreasingIndentation #-} +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Unistd +-- 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 miscellaneous stuff, mostly from unistd.h +-- +----------------------------------------------------------------------------- + +module System.Posix.Unistd ( + -- * System environment + SystemID(..), + getSystemID, + + SysVar(..), + getSysVar, + + -- * Sleeping + sleep, usleep, nanosleep, + + -- * File synchronisation + fileSynchronise, + fileSynchroniseDataOnly, + + {- + ToDo from unistd.h: + confstr, + lots of sysconf variables + + -- use Network.BSD + gethostid, gethostname + + -- should be in System.Posix.Files? + pathconf, fpathconf, + + -- System.Posix.Signals + ualarm, + + -- System.Posix.IO + read, write, + + -- should be in System.Posix.User? + getEffectiveUserName, +-} + ) where + +#include "HsUnix.h" + +import Foreign.C.Error +import Foreign.C.String ( peekCString ) +import Foreign.C.Types +import Foreign +import System.Posix.Types +import System.Posix.Internals + +#if !(HAVE_FSYNC && HAVE_FDATASYNC) +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- ----------------------------------------------------------------------------- +-- System environment (uname()) + +data SystemID = + SystemID { systemName :: String + , nodeName :: String + , release :: String + , version :: String + , machine :: String + } + +getSystemID :: IO SystemID +getSystemID = do + allocaBytes (#const sizeof(struct utsname)) $ \p_sid -> do + throwErrnoIfMinus1_ "getSystemID" (c_uname p_sid) + sysN <- peekCString ((#ptr struct utsname, sysname) p_sid) + node <- peekCString ((#ptr struct utsname, nodename) p_sid) + rel <- peekCString ((#ptr struct utsname, release) p_sid) + ver <- peekCString ((#ptr struct utsname, version) p_sid) + mach <- peekCString ((#ptr struct utsname, machine) p_sid) + return (SystemID { systemName = sysN, + nodeName = node, + release = rel, + version = ver, + machine = mach + }) + +foreign import ccall unsafe "uname" + c_uname :: Ptr CUtsname -> IO CInt + +-- ----------------------------------------------------------------------------- +-- sleeping + +-- | Sleep for the specified duration (in seconds). Returns the time remaining +-- (if the sleep was interrupted by a signal, for example). +-- +-- /GHC Note/: 'Control.Concurrent.threadDelay' is a better choice. Since GHC +-- uses signals for its internal clock, a call to 'sleep' will usually be +-- interrupted immediately. That makes 'sleep' unusable in a program compiled +-- with GHC, unless the RTS timer is disabled (with @+RTS -V0@). Furthermore, +-- without the @-threaded@ option, 'sleep' will block all other user threads. +-- Even with the @-threaded@ option, 'sleep' requires a full OS thread to +-- itself. 'Control.Concurrent.threadDelay' has none of these shortcomings. +-- +sleep :: Int -> IO Int +sleep 0 = return 0 +sleep secs = do r <- c_sleep (fromIntegral secs); return (fromIntegral r) + +{-# WARNING sleep "This function has several shortcomings (see documentation). Please consider using Control.Concurrent.threadDelay instead." #-} + +foreign import ccall safe "sleep" + c_sleep :: CUInt -> IO CUInt + +-- | Sleep for the specified duration (in microseconds). +-- +-- /GHC Note/: 'Control.Concurrent.threadDelay' is a better choice. +-- Without the @-threaded@ option, 'usleep' will block all other user +-- threads. Even with the @-threaded@ option, 'usleep' requires a +-- full OS thread to itself. 'Control.Concurrent.threadDelay' has +-- neither of these shortcomings. +-- +usleep :: Int -> IO () +#ifdef HAVE_NANOSLEEP +usleep usecs = nanosleep (fromIntegral usecs * 1000) +#else +usleep 0 = return () +#ifdef USLEEP_RETURNS_VOID +usleep usecs = c_usleep (fromIntegral usecs) +#else +usleep usecs = throwErrnoIfMinus1_ "usleep" (c_usleep (fromIntegral usecs)) +#endif + +#ifdef USLEEP_RETURNS_VOID +foreign import ccall safe "usleep" + c_usleep :: CUInt -> IO () +#else +foreign import ccall safe "usleep" + c_usleep :: CUInt -> IO CInt +#endif +#endif /* HAVE_NANOSLEEP */ + +-- | Sleep for the specified duration (in nanoseconds) +-- +-- /GHC Note/: the comment for 'usleep' also applies here. +nanosleep :: Integer -> IO () +#ifndef HAVE_NANOSLEEP +nanosleep = error "nanosleep: not available on this platform" +#else +nanosleep 0 = return () +nanosleep nsecs = do + allocaBytes (#const sizeof(struct timespec)) $ \pts1 -> do + allocaBytes (#const sizeof(struct timespec)) $ \pts2 -> do + let (tv_sec0, tv_nsec0) = nsecs `divMod` 1000000000 + let + loop tv_sec tv_nsec = do + (#poke struct timespec, tv_sec) pts1 tv_sec + (#poke struct timespec, tv_nsec) pts1 tv_nsec + res <- c_nanosleep pts1 pts2 + if res == 0 + then return () + else do errno <- getErrno + if errno == eINTR + then do + tv_sec' <- (#peek struct timespec, tv_sec) pts2 + tv_nsec' <- (#peek struct timespec, tv_nsec) pts2 + loop tv_sec' tv_nsec' + else throwErrno "nanosleep" + loop (fromIntegral tv_sec0 :: CTime) (fromIntegral tv_nsec0 :: CTime) + +data {-# CTYPE "struct timespec" #-} CTimeSpec + +foreign import capi safe "HsUnix.h nanosleep" + c_nanosleep :: Ptr CTimeSpec -> Ptr CTimeSpec -> IO CInt +#endif + +-- ----------------------------------------------------------------------------- +-- System variables + +data SysVar = ArgumentLimit + | ChildLimit + | ClockTick + | GroupLimit + | OpenFileLimit + | PosixVersion + | HasSavedIDs + | HasJobControl + -- ToDo: lots more + +getSysVar :: SysVar -> IO Integer +getSysVar v = + case v of + 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 + +-- ----------------------------------------------------------------------------- +-- File synchronization + +-- | Performs @fsync(2)@ operation on file-descriptor. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @fsync(2)@ (use @#if HAVE_FSYNC@ CPP guard to +-- detect availability). +-- +-- @since 2.7.1.0 +fileSynchronise :: Fd -> IO () +#if HAVE_FSYNC +fileSynchronise fd = do + throwErrnoIfMinus1_ "fileSynchronise" (c_fsync fd) + +foreign import capi safe "unistd.h fsync" + c_fsync :: Fd -> IO CInt +#else +{-# WARNING fileSynchronise + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_FSYNC@)" #-} +fileSynchronise _ = ioError (ioeSetLocation unsupportedOperation + "fileSynchronise") +#endif + +-- | Performs @fdatasync(2)@ operation on file-descriptor. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @fdatasync(2)@ (use @#if HAVE_FDATASYNC@ CPP guard to +-- detect availability). +-- +-- @since 2.7.1.0 +fileSynchroniseDataOnly :: Fd -> IO () +#if HAVE_FDATASYNC +fileSynchroniseDataOnly fd = do + throwErrnoIfMinus1_ "fileSynchroniseDataOnly" (c_fdatasync fd) + +foreign import capi safe "unistd.h fdatasync" + c_fdatasync :: Fd -> IO CInt +#else +{-# WARNING fileSynchroniseDataOnly + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_FDATASYNC@)" #-} +fileSynchroniseDataOnly _ = ioError (ioeSetLocation unsupportedOperation + "fileSynchroniseDataOnly") +#endif diff --git a/unix/System/Posix/User.hsc b/unix/System/Posix/User.hsc new file mode 100644 index 0000000..78af28f --- /dev/null +++ b/unix/System/Posix/User.hsc @@ -0,0 +1,474 @@ +{-# LANGUAGE Trustworthy, CApiFFI #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.User +-- 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 user\/group support +-- +----------------------------------------------------------------------------- + +module System.Posix.User ( + -- * User environment + -- ** Querying the user environment + getRealUserID, + getRealGroupID, + getEffectiveUserID, + getEffectiveGroupID, + getGroups, + getLoginName, + getEffectiveUserName, + + -- *** The group database + GroupEntry(..), + getGroupEntryForID, + getGroupEntryForName, + getAllGroupEntries, + + -- *** The user database + UserEntry(..), + getUserEntryForID, + getUserEntryForName, + getAllUserEntries, + + -- ** Modifying the user environment + setUserID, + setGroupID, + setEffectiveUserID, + setEffectiveGroupID, + setGroups + + ) where + +#include "HsUnix.h" + +import System.Posix.Types +import System.IO.Unsafe (unsafePerformIO) +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable + +#if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT) +import Control.Concurrent.MVar ( MVar, newMVar, withMVar ) +#endif +#ifdef HAVE_GETPWENT +import Control.Exception +#endif +import Control.Monad +import System.IO.Error + +-- internal types +data {-# CTYPE "struct passwd" #-} CPasswd +data {-# CTYPE "struct group" #-} CGroup + +-- ----------------------------------------------------------------------------- +-- user environment + +-- | @getRealUserID@ calls @getuid@ to obtain the real @UserID@ +-- associated with the current process. +getRealUserID :: IO UserID +getRealUserID = c_getuid + +foreign import ccall unsafe "getuid" + c_getuid :: IO CUid + +-- | @getRealGroupID@ calls @getgid@ to obtain the real @GroupID@ +-- associated with the current process. +getRealGroupID :: IO GroupID +getRealGroupID = c_getgid + +foreign import ccall unsafe "getgid" + c_getgid :: IO CGid + +-- | @getEffectiveUserID@ calls @geteuid@ to obtain the effective +-- @UserID@ associated with the current process. +getEffectiveUserID :: IO UserID +getEffectiveUserID = c_geteuid + +foreign import ccall unsafe "geteuid" + c_geteuid :: IO CUid + +-- | @getEffectiveGroupID@ calls @getegid@ to obtain the effective +-- @GroupID@ associated with the current process. +getEffectiveGroupID :: IO GroupID +getEffectiveGroupID = c_getegid + +foreign import ccall unsafe "getegid" + c_getegid :: IO CGid + +-- | @getGroups@ calls @getgroups@ to obtain the list of +-- supplementary @GroupID@s associated with the current process. +getGroups :: IO [GroupID] +getGroups = do + ngroups <- c_getgroups 0 nullPtr + allocaArray (fromIntegral ngroups) $ \arr -> do + throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr) + groups <- peekArray (fromIntegral ngroups) arr + return groups + +foreign import ccall unsafe "getgroups" + c_getgroups :: CInt -> Ptr CGid -> IO CInt + + +-- | @setGroups@ calls @setgroups@ to set the list of +-- supplementary @GroupID@s associated with the current process. +setGroups :: [GroupID] -> IO () +setGroups groups = do + withArrayLen groups $ \ ngroups arr -> + throwErrnoIfMinus1_ "setGroups" (c_setgroups (fromIntegral ngroups) arr) + +foreign import ccall unsafe "setgroups" + c_setgroups :: CInt -> Ptr CGid -> IO CInt + + + +-- | @getLoginName@ calls @getlogin@ to obtain the login name +-- associated with the current process. +getLoginName :: IO String +getLoginName = do + -- ToDo: use getlogin_r + str <- throwErrnoIfNull "getLoginName" c_getlogin + peekCAString str + +foreign import ccall unsafe "getlogin" + c_getlogin :: IO CString + +-- | @setUserID uid@ calls @setuid@ to set the real, effective, and +-- saved set-user-id associated with the current process to @uid@. +setUserID :: UserID -> IO () +setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid) + +foreign import ccall unsafe "setuid" + c_setuid :: CUid -> IO CInt + +-- | @setEffectiveUserID uid@ calls @seteuid@ to set the effective +-- user-id associated with the current process to @uid@. This +-- does not update the real user-id or set-user-id. +setEffectiveUserID :: UserID -> IO () +setEffectiveUserID uid = throwErrnoIfMinus1_ "setEffectiveUserID" (c_seteuid uid) + +foreign import ccall unsafe "seteuid" + c_seteuid :: CUid -> IO CInt + +-- | @setGroupID gid@ calls @setgid@ to set the real, effective, and +-- saved set-group-id associated with the current process to @gid@. +setGroupID :: GroupID -> IO () +setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid) + +foreign import ccall unsafe "setgid" + c_setgid :: CGid -> IO CInt + +-- | @setEffectiveGroupID uid@ calls @setegid@ to set the effective +-- group-id associated with the current process to @gid@. This +-- does not update the real group-id or set-group-id. +setEffectiveGroupID :: GroupID -> IO () +setEffectiveGroupID gid = + throwErrnoIfMinus1_ "setEffectiveGroupID" (c_setegid gid) + + +foreign import ccall unsafe "setegid" + c_setegid :: CGid -> IO CInt + +-- ----------------------------------------------------------------------------- +-- User names + +-- | @getEffectiveUserName@ gets the name +-- associated with the effective @UserID@ of the process. +getEffectiveUserName :: IO String +getEffectiveUserName = do + euid <- getEffectiveUserID + pw <- getUserEntryForID euid + return (userName pw) + +-- ----------------------------------------------------------------------------- +-- The group database (grp.h) + +data GroupEntry = + GroupEntry { + groupName :: String, -- ^ The name of this group (gr_name) + groupPassword :: String, -- ^ The password for this group (gr_passwd) + groupID :: GroupID, -- ^ The unique numeric ID for this group (gr_gid) + groupMembers :: [String] -- ^ A list of zero or more usernames that are members (gr_mem) + } deriving (Show, Read, Eq) + +-- | @getGroupEntryForID gid@ calls @getgrgid_r@ to obtain +-- the @GroupEntry@ information associated with @GroupID@ +-- @gid@. This operation may fail with 'isDoesNotExistError' +-- if no such group exists. +getGroupEntryForID :: GroupID -> IO GroupEntry +#ifdef HAVE_GETGRGID_R +getGroupEntryForID gid = + allocaBytes (#const sizeof(struct group)) $ \pgr -> + doubleAllocWhileERANGE "getGroupEntryForID" "group" grBufSize unpackGroupEntry $ + c_getgrgid_r gid pgr + +foreign import capi unsafe "HsUnix.h getgrgid_r" + c_getgrgid_r :: CGid -> Ptr CGroup -> CString + -> CSize -> Ptr (Ptr CGroup) -> IO CInt +#else +getGroupEntryForID = error "System.Posix.User.getGroupEntryForID: not supported" +#endif + +-- | @getGroupEntryForName name@ calls @getgrnam_r@ to obtain +-- the @GroupEntry@ information associated with the group called +-- @name@. This operation may fail with 'isDoesNotExistError' +-- if no such group exists. +getGroupEntryForName :: String -> IO GroupEntry +#ifdef HAVE_GETGRNAM_R +getGroupEntryForName name = + allocaBytes (#const sizeof(struct group)) $ \pgr -> + withCAString name $ \ pstr -> + doubleAllocWhileERANGE "getGroupEntryForName" "group" grBufSize unpackGroupEntry $ + c_getgrnam_r pstr pgr + +foreign import capi unsafe "HsUnix.h getgrnam_r" + c_getgrnam_r :: CString -> Ptr CGroup -> CString + -> CSize -> Ptr (Ptr CGroup) -> IO CInt +#else +getGroupEntryForName = error "System.Posix.User.getGroupEntryForName: not supported" +#endif + +-- | @getAllGroupEntries@ returns all group entries on the system by +-- repeatedly calling @getgrent@ + +-- +-- getAllGroupEntries may fail with isDoesNotExistError on Linux due to +-- this bug in glibc: +-- http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647 +-- +getAllGroupEntries :: IO [GroupEntry] +#ifdef HAVE_GETGRENT +getAllGroupEntries = + withMVar lock $ \_ -> bracket_ c_setgrent c_endgrent $ worker [] + where worker accum = + do resetErrno + ppw <- throwErrnoIfNullAndError "getAllGroupEntries" $ + c_getgrent + if ppw == nullPtr + then return (reverse accum) + else do thisentry <- unpackGroupEntry ppw + worker (thisentry : accum) + +foreign import ccall unsafe "getgrent" + c_getgrent :: IO (Ptr CGroup) +foreign import ccall unsafe "setgrent" + c_setgrent :: IO () +foreign import ccall unsafe "endgrent" + c_endgrent :: IO () +#else +getAllGroupEntries = error "System.Posix.User.getAllGroupEntries: not supported" +#endif + +#if defined(HAVE_GETGRGID_R) || defined(HAVE_GETGRNAM_R) +grBufSize :: Int +#if defined(HAVE_SYSCONF) && defined(HAVE_SC_GETGR_R_SIZE_MAX) +grBufSize = sysconfWithDefault 1024 (#const _SC_GETGR_R_SIZE_MAX) +#else +grBufSize = 1024 +#endif +#endif + +unpackGroupEntry :: Ptr CGroup -> IO GroupEntry +unpackGroupEntry ptr = do + 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 peekCAString + return (GroupEntry name passwd gid members) + +-- ----------------------------------------------------------------------------- +-- The user database (pwd.h) + +data UserEntry = + UserEntry { + userName :: String, -- ^ Textual name of this user (pw_name) + userPassword :: String, -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd) + userID :: UserID, -- ^ Numeric ID for this user (pw_uid) + userGroupID :: GroupID, -- ^ Primary group ID (pw_gid) + userGecos :: String, -- ^ Usually the real name for the user (pw_gecos) + homeDirectory :: String, -- ^ Home directory (pw_dir) + userShell :: String -- ^ Default shell (pw_shell) + } deriving (Show, Read, Eq) + +-- +-- getpwuid and getpwnam leave results in a static object. Subsequent +-- calls modify the same object, which isn't threadsafe. We attempt to +-- mitigate this issue, on platforms that don't provide the safe _r versions +-- +-- Also, getpwent/setpwent require a global lock since they maintain +-- an internal file position pointer. +#if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT) +lock :: MVar () +lock = unsafePerformIO $ newMVar () +{-# NOINLINE lock #-} +#endif + +-- | @getUserEntryForID gid@ calls @getpwuid_r@ to obtain +-- the @UserEntry@ information associated with @UserID@ +-- @uid@. This operation may fail with 'isDoesNotExistError' +-- if no such user exists. +getUserEntryForID :: UserID -> IO UserEntry +#ifdef HAVE_GETPWUID_R +getUserEntryForID uid = + allocaBytes (#const sizeof(struct passwd)) $ \ppw -> + doubleAllocWhileERANGE "getUserEntryForID" "user" pwBufSize unpackUserEntry $ + c_getpwuid_r uid ppw + +foreign import capi unsafe "HsUnix.h getpwuid_r" + c_getpwuid_r :: CUid -> Ptr CPasswd -> + CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt +#elif HAVE_GETPWUID +getUserEntryForID uid = do + withMVar lock $ \_ -> do + ppw <- throwErrnoIfNull "getUserEntryForID" $ c_getpwuid uid + unpackUserEntry ppw + +foreign import ccall unsafe "getpwuid" + c_getpwuid :: CUid -> IO (Ptr CPasswd) +#else +getUserEntryForID = error "System.Posix.User.getUserEntryForID: not supported" +#endif + +-- | @getUserEntryForName name@ calls @getpwnam_r@ to obtain +-- the @UserEntry@ information associated with the user login +-- @name@. This operation may fail with 'isDoesNotExistError' +-- if no such user exists. +getUserEntryForName :: String -> IO UserEntry +#if HAVE_GETPWNAM_R +getUserEntryForName name = + allocaBytes (#const sizeof(struct passwd)) $ \ppw -> + withCAString name $ \ pstr -> + doubleAllocWhileERANGE "getUserEntryForName" "user" pwBufSize unpackUserEntry $ + c_getpwnam_r pstr ppw + +foreign import capi unsafe "HsUnix.h getpwnam_r" + c_getpwnam_r :: CString -> Ptr CPasswd + -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt +#elif HAVE_GETPWNAM +getUserEntryForName name = do + withCAString name $ \ pstr -> do + withMVar lock $ \_ -> do + ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr + unpackUserEntry ppw + +foreign import ccall unsafe "getpwnam" + c_getpwnam :: CString -> IO (Ptr CPasswd) +#else +getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported" +#endif + +-- | @getAllUserEntries@ returns all user entries on the system by +-- repeatedly calling @getpwent@ +getAllUserEntries :: IO [UserEntry] +#ifdef HAVE_GETPWENT +getAllUserEntries = + withMVar lock $ \_ -> bracket_ c_setpwent c_endpwent $ worker [] + where worker accum = + do resetErrno + ppw <- throwErrnoIfNullAndError "getAllUserEntries" $ + c_getpwent + if ppw == nullPtr + then return (reverse accum) + else do thisentry <- unpackUserEntry ppw + worker (thisentry : accum) + +foreign import capi unsafe "HsUnix.h getpwent" + c_getpwent :: IO (Ptr CPasswd) +foreign import capi unsafe "HsUnix.h setpwent" + c_setpwent :: IO () +foreign import capi unsafe "HsUnix.h endpwent" + c_endpwent :: IO () +#else +getAllUserEntries = error "System.Posix.User.getAllUserEntries: not supported" +#endif + +#if defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWNAM_R) +pwBufSize :: Int +#if defined(HAVE_SYSCONF) && defined(HAVE_SC_GETPW_R_SIZE_MAX) +pwBufSize = sysconfWithDefault 1024 (#const _SC_GETPW_R_SIZE_MAX) +#else +pwBufSize = 1024 +#endif +#endif + +#ifdef HAVE_SYSCONF +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> IO CLong + +-- We need a default value since sysconf can fail and return -1 +-- even when the parameter name is defined in unistd.h. +-- One example of this is _SC_GETPW_R_SIZE_MAX under +-- Mac OS X 10.4.9 on i386. +sysconfWithDefault :: Int -> CInt -> Int +sysconfWithDefault def sc = + unsafePerformIO $ do v <- fmap fromIntegral $ c_sysconf sc + return $ if v == (-1) then def else v +#endif + +-- The following function is used by the getgr*_r, c_getpw*_r +-- families of functions. These functions return their result +-- in a struct that contains strings and they need a buffer +-- that they can use to store those strings. We have to be +-- careful to unpack the struct containing the result before +-- the buffer is deallocated. +doubleAllocWhileERANGE + :: String + -> String -- entry type: "user" or "group" + -> Int + -> (Ptr r -> IO a) + -> (Ptr b -> CSize -> Ptr (Ptr r) -> IO CInt) + -> IO a +doubleAllocWhileERANGE loc enttype initlen unpack action = + alloca $ go initlen + where + go len res = do + r <- allocaBytes len $ \buf -> do + rc <- action buf (fromIntegral len) res + if rc /= 0 + then return (Left rc) + else do p <- peek res + when (p == nullPtr) $ notFoundErr + fmap Right (unpack p) + case r of + Right x -> return x + Left rc | Errno rc == eRANGE -> + -- ERANGE means this is not an error + -- we just have to try again with a larger buffer + go (2 * len) res + Left rc -> + ioError (errnoToIOError loc (Errno rc) Nothing Nothing) + notFoundErr = + ioError $ flip ioeSetErrorString ("no such " ++ enttype) + $ mkIOError doesNotExistErrorType loc Nothing Nothing + +unpackUserEntry :: Ptr CPasswd -> IO UserEntry +unpackUserEntry ptr = do + 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 +#ifdef HAVE_NO_PASSWD_PW_GECOS + gecos <- return "" -- pw_gecos does not exist on android +#else + gecos <- (#peek struct passwd, pw_gecos) ptr >>= peekCAString +#endif + 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 a function returns NULL to indicate either an error or +-- EOF, depending on whether the global errno is nonzero. +throwErrnoIfNullAndError :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNullAndError loc act = do + rc <- act + errno <- getErrno + if rc == nullPtr && errno /= eOK + then throwErrno loc + else return rc diff --git a/unix/aclocal.m4 b/unix/aclocal.m4 new file mode 100644 index 0000000..8255156 --- /dev/null +++ b/unix/aclocal.m4 @@ -0,0 +1,49 @@ +# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS) +# -------------------------------------------------------- +# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for +# compilation. Execute IF-FAILS when unable to determine the value. Works for +# cross-compilation, too. +# +# Implementation note: We are lazy and use an internal autoconf macro, but it +# is supported in autoconf versions 2.50 up to the actual 2.57, so there is +# little risk. +AC_DEFUN([FP_COMPUTE_INT], +[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl +])# FP_COMPUTE_INT + + +# FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1]) +# ------------------------------------------------------------------------------- +# Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using +# INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL. +AC_DEFUN([FP_CHECK_CONST], +[AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl +AC_CACHE_CHECK([value of $1], fp_Cache, +[FP_COMPUTE_INT([$1], fp_check_const_result, [AC_INCLUDES_DEFAULT([$2])], + [fp_check_const_result=m4_default([$3], ['-1'])]) +AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl +AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl +AS_VAR_POPDEF([fp_Cache])[]dnl +])# FP_CHECK_CONST + + +# FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...) +# --------------------------------------- +# autoheader helper for FP_CHECK_CONSTS +m4_define([FP_CHECK_CONSTS_TEMPLATE], +[AC_FOREACH([fp_Const], [$1], + [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const), + [The value of ]fp_Const[.])])[]dnl +])# FP_CHECK_CONSTS_TEMPLATE + + +# FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1]) +# ----------------------------------------------------------------------------------- +# List version of FP_CHECK_CONST +AC_DEFUN([FP_CHECK_CONSTS], +[FP_CHECK_CONSTS_TEMPLATE([$1])dnl +for fp_const_name in $1 +do +FP_CHECK_CONST([$fp_const_name], [$2], [$3]) +done +])# FP_CHECK_CONSTS diff --git a/unix/cabal.haskell-ci b/unix/cabal.haskell-ci new file mode 100644 index 0000000..becc668 --- /dev/null +++ b/unix/cabal.haskell-ci @@ -0,0 +1,2 @@ +ghc-head: True +unconstrained: False diff --git a/unix/cabal.project b/unix/cabal.project new file mode 100644 index 0000000..e6fdbad --- /dev/null +++ b/unix/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/unix/cbits/HsUnix.c b/unix/cbits/HsUnix.c new file mode 100644 index 0000000..7c72a34 --- /dev/null +++ b/unix/cbits/HsUnix.c @@ -0,0 +1,116 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2002 + * + * Definitions for package `unix' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +#include "HsUnix.h" + +#ifdef HAVE_RTLDNEXT +void *__hsunix_rtldNext (void) {return RTLD_NEXT;} +#endif + +#ifdef HAVE_RTLDDEFAULT +void *__hsunix_rtldDefault (void) {return RTLD_DEFAULT;} +#endif + +#if HAVE_PTSNAME && (__GLASGOW_HASKELL__ < 800) +// On Linux (and others), needs to be included while +// `_XOPEN_SOURCE` is already defined. However, GHCs before GHC 8.0 +// didn't do that yet for CApiFFI, so we need this workaround here. + +char *__hsunix_ptsname(int fd) { return ptsname(fd); } +int __hsunix_grantpt(int fd) { return grantpt(fd); } +int __hsunix_unlockpt(int fd) { return unlockpt(fd); } +#endif + +// push a SVR4 STREAMS module; do nothing if STREAMS not available +int __hsunix_push_module(int fd, const char *module) +{ +#if defined(I_PUSH) && !defined(HAVE_DEV_PTC) + return ioctl(fd, I_PUSH, module); +#else + return 0; +#endif +} + +/* + * GNU glibc 2.23 and later deprecate `readdir_r` in favour of plain old + * `readdir` which in some upcoming POSIX standard is going to required to be + * re-entrant. + * Eventually we want to drop `readder_r` all together, but want to be + * compatible with older unixen which may not have a re-entrant `readdir`. + * Solution is to make systems with *known* re-entrant `readir` use that and use + * `readdir_r` whereever we have it and don't *know* that `readdir` is + * re-entrant. + */ + +#if defined (__GLIBC__) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ >= 23) +#define USE_READDIR_R 0 +#else +#define USE_READDIR_R 1 +#endif + +/* + * read an entry from the directory stream; opt for the + * re-entrant friendly way of doing this, if available. + */ +int __hscore_readdir( DIR *dirPtr, struct dirent **pDirEnt ) +{ +#if HAVE_READDIR_R && USE_READDIR_R + struct dirent* p; + int res; + static unsigned int nm_max = (unsigned int)-1; + + if (pDirEnt == NULL) { + return -1; + } + if (nm_max == (unsigned int)-1) { +#ifdef NAME_MAX + nm_max = NAME_MAX + 1; +#else + nm_max = pathconf(".", _PC_NAME_MAX); + if (nm_max == -1) { nm_max = 255; } + nm_max++; +#endif + } + p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max); + if (p == NULL) return -1; + res = readdir_r(dirPtr, p, pDirEnt); + if (res != 0) { + *pDirEnt = NULL; + free(p); + } + else if (*pDirEnt == NULL) { + // end of stream + free(p); + } + return res; +#else + + if (pDirEnt == NULL) { + return -1; + } + + *pDirEnt = readdir(dirPtr); + if (*pDirEnt == NULL) { + return -1; + } else { + return 0; + } +#endif +} + +char *__hscore_d_name( struct dirent* d ) +{ + return (d->d_name); +} + +void __hscore_free_dirent(struct dirent *dEnt) +{ +#if HAVE_READDIR_R && USE_READDIR_R + free(dEnt); +#endif +} diff --git a/unix/cbits/execvpe.c b/unix/cbits/execvpe.c new file mode 100644 index 0000000..9af3acc --- /dev/null +++ b/unix/cbits/execvpe.c @@ -0,0 +1,173 @@ +/* ----------------------------------------------------------------------------- + (c) The University of Glasgow 1995-2004 + + Our low-level exec() variant. + + Note: __hsunix_execvpe() is very similiar to the function + execvpe(3) as provided by glibc 2.11 and later. However, if + execvpe(3) is available, we use that instead. + + -------------------------------------------------------------------------- */ + +#include "HsUnixConfig.h" + +#include +#include +#if HAVE_SYS_WAIT_H +# include +#endif +#include +#include +#include +#include +#include + +#include "execvpe.h" + +#if !defined(execvpe) && !HAVE_DECL_EXECVPE +// On some archs such as AIX, the prototype may be missing +int execvpe(const char *file, char *const argv[], char *const envp[]); +#endif + +/* + * 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 +__hsunix_execvpe(const char *name, char *const argv[], char *const envp[]) +{ +#if HAVE_EXECVPE + return execvpe(name, argv, envp); +#else + register int lp, ln; + register char *p; + int eacces=0, etxtbsy=0; + char *bp, *cur, *path, *buf = 0; + + /* 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 ENOTDIR: + 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); +#endif +} diff --git a/unix/changelog.md b/unix/changelog.md new file mode 100644 index 0000000..420cae3 --- /dev/null +++ b/unix/changelog.md @@ -0,0 +1,150 @@ +# Changelog for [`unix` package](http://hackage.haskell.org/package/unix) + +## 2.8.0.0 *UNRELEASED* + + * Added terminal output flags to `System.Posix.Terminal.Common.TerminalMode` + + IXANY, ONLCR, OCRNL, ONOCR, ONLRET, OFDEL, OFILL, NLDLY(NL0,NL1), + CRDLY(CR0,CR1,CR2,CR2), TABDLY(TAB0,TAB1,TAB2,TAB3) BSDLY(BS0,BS1), + VTDLY(VT0,VT1), FFDLY(FF0,FF1) + + * Add support for `O_NOFOLLOW`, `O_CLOEXEC`, `O_DIRECTORY` and `O_SYNC` + (#6, #57) + + * Refactor API of `openFd` removing `Maybe FileMode` argument, + which now must be passed as part of `OpenFileFlags` + (e.g. `defaultFileFlags { creat = Just mode }`) (#58) + + * Remove deprecated `execvpe(3)` legacy-emulation CPP macro + + * Generalise return type of `exitImmediately` from `ExitCode -> IO ()` to + `∀a. ExitCode -> IO a` (#130) + + * Add `Read`, `Show`, `Eq`, and `Ord` typeclass instances to `OpenFileFlags` and `OpenMode`. (#75, #141) + +## 2.7.2.2 *May 2017* + + * Bundled with GHC 8.2.1 + + * Improve Autoconf detection of `telldir`/`seekdir` and define + `_POSIX_VDISABLE` if missing for Android (#91,#90) + + * Fix error message of `createSymbolicLink` (#84) + +## 2.7.2.1 *Nov 2016* + + * Bundled with GHC 8.0.2 + + * Don't use `readdir_r` if its deprecated. + + * Add argument documentation for Env modules + +## 2.7.2.0 *Apr 2016* + + * Bundled with GHC 8.0.1 + + * Don't assume non-POSIX `WCOREDUMP(x)` macro exists + + * Don't assume existence of `termios(3)` constants beyond `B38400` + + * Don't assume existence of `ctermid(3)`/`tcdrain(3)` + + * Change `drainOutput`'s `tcdrain(3)` into a `safe` FFI call + + * Turn build error into compile warnings for exotic `struct stat` + configurations (GHC #8859) + + * Improve detection of `fdatasync(2)` (GHC #11137) + + * Drop support for Hugs + + * Drop support for Cygwin (and Windows in general) + +## 2.7.1.0 *Dec 2014* + + * Bundled with GHC 7.10.1 + + * Add support for `base-4.8.0.0` + + * Tighten `SafeHaskell` bounds for GHC 7.10+ + + * Add haddock comments on `RTLD_NEXT` and `RTLD_DEFAULT` + + * Deprecate function `haveRtldLocal` + + * Fix `getGroupEntryForID/getGroupEntryForName` on Solaris. Solaris uses + CPP macros for required `getgrgid_r` and `getgrnam_r` functions definition + so the fix is to change from C ABI calling convention to C API calling + convention + + * Fix potential type-mismatch in `telldir`/`seekdir` FFI imports + + * Use CAPI FFI import for `truncate` to make sure the LFS-version is used. + + * `executeFile`: Fix `ENOTDIR` error for entries with non-directory + components in `PATH` (and instead skip over non-directory `PATH`-elements) + + * New functions in `System.Posix.Unistd`: + - `fileSynchronise` (aka `fsync(2)`), and + - `fileSynchroniseDataOnly` (aka `fdatasync(2)`) + + * New module `System.Posix.Fcntl` providing + - `fileAdvise` (aka `posix_fadvise(2)`), and + - `fileAllocate` (aka `posix_fallocate(2)`) + + * Fix SIGINFO and SIGWINCH definitions + +## 2.7.0.1 *Mar 2014* + + * Bundled with GHC 7.8.1 + + * Handle `EROFS` and `ETXTBSY` as (non-exceptional) permission denied in + `fileAccess` + + * Fix `getFileStatus` to retry `stat(2)` when it returns `EAGAIN` + (this can happen on Solaris) + +## 2.7.0.0 *Nov 2013* + + * New `forkProcessWithUnmask` function in the style of `forkIOWithUnmask` + + * Change `forkProcess` to inherit the exception masking state of its caller + + * Add new `Bool` flag to `ProcessStatus(Terminated)` constructor + indicating whether a core dump occured + + * New functions in `System.Posix.Files{,.ByteString}` for operating + on high resolution file timestamps: + + setFdTimesHiRes :: Fd -> POSIXTime -> POSIXTime -> IO () + setFileTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () + setSymbolicLinkTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () + touchFd :: Fd -> IO () + touchSymbolicLink :: FilePath -> IO () + + * Export `SignalInfo(..)` and `SignalSpecificInfo(..)` as well as + the two `Handler` constructors `CatchInfo` and `CatchInfoOnce` + from `System.Posix.Signals` + + * Don't export `seekDirStream` and `tellDirStream` if the underlying + `seekdir(3)`/`telldir(3)` system calls are not available (as on Android) + + * Fix library detection of `shm*` on openSUSE (#8350) + + * Minor documentation fixes/updates + + * Update package to `cabal-version >= 1.10` format + +## 2.6.0.1 *Jan 2013* + + * Bundled with GHC 7.6.2 + * Fix memory corruption issue in `putEnv` + * Use `pthread_kill(3)` instead of `raise(2)` on OS X too + +## 2.6.0.0 *Sep 2012* + + * Bundled with GHC 7.6.1 + * New functions `mkdtemp` and `mkstemps` in `System.Posix.Temp` + * New functions `setEnvironment` and `cleanEnv` + * New functions `accessTimeHiRes`, `modificationTimeHiRes`, and + `statusChangeTimeHiRes` for accessing high resolution timestamps diff --git a/unix/config.guess b/unix/config.guess new file mode 100755 index 0000000..69ed3e5 --- /dev/null +++ b/unix/config.guess @@ -0,0 +1,1466 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright 1992-2017 Free Software Foundation, Inc. + +timestamp='2017-03-05' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). +# +# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. +# +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess +# +# Please send patches to . + + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright 1992-2017 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +case "${UNAME_SYSTEM}" in +Linux|GNU|GNU/*) + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + LIBC=gnu + + eval $set_cc_for_build + cat <<-EOF > $dummy.c + #include + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #else + LIBC=gnu + #endif + EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` + ;; +esac + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ + /sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || \ + echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + earmv*) + arch=`echo ${UNAME_MACHINE_ARCH} | sed -e 's,^e\(armv[0-9]\).*$,\1,'` + endian=`echo ${UNAME_MACHINE_ARCH} | sed -ne 's,^.*\(eb\)$,\1,p'` + machine=${arch}${endian}-unknown + ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently (or will in the future) and ABI. + case "${UNAME_MACHINE_ARCH}" in + earm*) + os=netbsdelf + ;; + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # Determine ABI tags. + case "${UNAME_MACHINE_ARCH}" in + earm*) + expr='s/^earmv[0-9]/-eabi/;s/eb$//' + abi=`echo ${UNAME_MACHINE_ARCH} | sed -e "$expr"` + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE} | sed -e 's/[-_].*//' | cut -d. -f1,2` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}${abi}" + exit ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:LibertyBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-libertybsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:Sortix:*:*) + echo ${UNAME_MACHINE}-unknown-sortix + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE=alpha ;; + "EV4.5 (21064)") + UNAME_MACHINE=alpha ;; + "LCA4 (21066/21068)") + UNAME_MACHINE=alpha ;; + "EV5 (21164)") + UNAME_MACHINE=alphaev5 ;; + "EV5.6 (21164A)") + UNAME_MACHINE=alphaev56 ;; + "EV5.6 (21164PC)") + UNAME_MACHINE=alphapca56 ;; + "EV5.7 (21164PC)") + UNAME_MACHINE=alphapca57 ;; + "EV6 (21264)") + UNAME_MACHINE=alphaev6 ;; + "EV6.7 (21264A)") + UNAME_MACHINE=alphaev67 ;; + "EV6.8CB (21264C)") + UNAME_MACHINE=alphaev68 ;; + "EV6.8AL (21264B)") + UNAME_MACHINE=alphaev68 ;; + "EV6.8CX (21264D)") + UNAME_MACHINE=alphaev68 ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE=alphaev69 ;; + "EV7 (21364)") + UNAME_MACHINE=alphaev7 ;; + "EV7.9 (21364A)") + UNAME_MACHINE=alphaev79 ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH=i386 + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH=x86_64 + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = x && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/lslpp ] ; then + IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | + awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0 + 528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH=hppa2.0n ;; + 64) HP_ARCH=hppa2.0w ;; + '') HP_ARCH=hppa2.0 ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS="" $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = hppa2.0w ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH=hppa2.0w + else + HP_ARCH=hppa64 + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + UNAME_PROCESSOR=x86_64 ;; + i386) + UNAME_PROCESSOR=i586 ;; + esac + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + *:MINGW64*:*) + echo ${UNAME_MACHINE}-pc-mingw64 + exit ;; + *:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + *:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + aarch64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC=gnulibc1 ; fi + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arc:Linux:*:* | arceb:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi + else + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf + fi + fi + exit ;; + avr32*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + cris:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + crisv32:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + e2k:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + frv:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + hexagon:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:Linux:*:*) + echo ${UNAME_MACHINE}-pc-linux-${LIBC} + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + k1om:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=${UNAME_MACHINE}el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=${UNAME_MACHINE} + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } + ;; + mips64el:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + openrisc*:Linux:*:*) + echo or1k-unknown-linux-${LIBC} + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-${LIBC} + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; + PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; + *) echo hppa-unknown-linux-${LIBC} ;; + esac + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-${LIBC} + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-${LIBC} + exit ;; + ppc64le:Linux:*:*) + echo powerpc64le-unknown-linux-${LIBC} + exit ;; + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-${LIBC} + exit ;; + riscv32:Linux:*:* | riscv64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux-${LIBC} + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-${LIBC} + exit ;; + x86_64:Linux:*:*) + echo ${UNAME_MACHINE}-pc-linux-${LIBC} + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configure will decide that + # this is a cross-build. + echo i586-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; + x86_64:Haiku:*:*) + echo x86_64-unknown-haiku + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; + SX-ACE:SUPER-UX:*:*) + echo sxace-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + eval $set_cc_for_build + if test "$UNAME_PROCESSOR" = unknown ; then + UNAME_PROCESSOR=powerpc + fi + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 + fi + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = x86; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-*:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + NSX-?:NONSTOP_KERNEL:*:*) + echo nsx-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = 386; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE} | sed -e 's/ .*$//'` + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; + x86_64:VMkernel:*:*) + echo ${UNAME_MACHINE}-unknown-esx + exit ;; + amd64:Isilon\ OneFS:*:*) + echo x86_64-unknown-onefs + exit ;; +esac + +cat >&2 </dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/unix/config.sub b/unix/config.sub new file mode 100755 index 0000000..40ea5df --- /dev/null +++ b/unix/config.sub @@ -0,0 +1,1836 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright 1992-2017 Free Software Foundation, Inc. + +timestamp='2017-04-02' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches to . +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2017 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ + kopensolaris*-gnu* | cloudabi*-eabi* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + android-linux) + os=-linux-android + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray | -microblaze*) + os= + basic_machine=$1 + ;; + -bluegene*) + os=-cnk + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*178) + os=-lynxos178 + ;; + -lynx*5) + os=-lynxos5 + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arceb \ + | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ + | avr | avr32 \ + | ba \ + | be32 | be64 \ + | bfin \ + | c4x | c8051 | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | e2k | epiphany \ + | fido | fr30 | frv | ft32 \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia16 | ia64 \ + | ip2k | iq2000 \ + | k1om \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipsr5900 | mipsr5900el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 | nios2eb | nios2el \ + | ns16k | ns32k \ + | open8 | or1k | or1knd | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pru \ + | pyramid \ + | riscv32 | riscv64 \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | visium \ + | wasm32 \ + | we32k \ + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + leon|leon[3-9]) + basic_machine=sparc-$basic_machine + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xgate) + basic_machine=$basic_machine-unknown + os=-none + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* | avr32-* \ + | ba-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | c8051-* | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | e2k-* | elxsi-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ + | ip2k-* | iq2000-* \ + | k1om-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ + | microblaze-* | microblazeel-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipsr5900-* | mipsr5900el-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* | nios2eb-* | nios2el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | or1k*-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pru-* \ + | pyramid-* \ + | riscv32-* | riscv64-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | visium-* \ + | wasm32-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aros) + basic_machine=i386-pc + os=-aros + ;; + asmjs) + basic_machine=asmjs-unknown + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + e500v[12]) + basic_machine=powerpc-unknown + os=$os"spe" + ;; + e500v[12]-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + os=$os"spe" + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + leon-*|leon[3-9]-*) + basic_machine=sparc-`echo $basic_machine | sed 's/-.*//'` + ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + microblaze*) + basic_machine=microblaze-xilinx + ;; + mingw64) + basic_machine=x86_64-pc + os=-mingw64 + ;; + mingw32) + basic_machine=i686-pc + os=-mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + moxiebox) + basic_machine=moxie-unknown + os=-moxiebox + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i686-pc + os=-msys + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + nsx-tandem) + basic_machine=nsx-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + os=-rdos + ;; + rdos32) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + wasm32) + basic_machine=wasm32-unknown + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* | -plan9* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* | -aros* | -cloudabi* | -sortix* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* | -cegcc* | -glidix* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-musl* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \ + | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; + -ios) + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + c8051-*) + os=-elf + ;; + hexagon-*) + os=-elf + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + ;; + m68*-cisco) + os=-aout + ;; + mep-*) + os=-elf + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + pru-*) + os=-elf + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -cnk*|-aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/unix/configure.ac b/unix/configure.ac new file mode 100644 index 0000000..c23c9e1 --- /dev/null +++ b/unix/configure.ac @@ -0,0 +1,240 @@ +AC_PREREQ([2.60]) +AC_INIT([Haskell unix package], [2.0], [libraries@haskell.org], [unix]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([include/HsUnix.h]) + +AC_PROG_CC + +dnl make extensions visible to allow feature-tests to detect them lateron +AC_USE_SYSTEM_EXTENSIONS + +AC_CONFIG_HEADERS([include/HsUnixConfig.h]) + +# Is this a Unix system? +AC_CHECK_HEADER([dlfcn.h], [BUILD_PACKAGE_BOOL=True], [BUILD_PACKAGE_BOOL=False]) +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_C_CONST + +dnl ** Enable large file support. NB. do this before testing the type of +dnl off_t, because it will affect the result of that test. +dnl +dnl WARNING: It's essential this check agrees with HsBaseConfig.h as otherwise +dnl the definitions of COff/coff_t don't line up +AC_SYS_LARGEFILE + +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([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]) +AC_CHECK_FUNCS([getpwent getgrent]) +AC_CHECK_FUNCS([lchown setenv sysconf unsetenv clearenv]) +AC_CHECK_FUNCS([nanosleep]) +AC_CHECK_FUNCS([ptsname]) +AC_CHECK_FUNCS([setitimer]) +AC_CHECK_FUNCS([readdir_r]) + +dnl not available on android so check for it +AC_CANONICAL_TARGET +AS_CASE([$target_os],[*-android*],[],[AC_CHECK_FUNCS([telldir seekdir])]) + +dnl When available, _NSGetEnviron() (defined in ) is +dnl the preferred way to access environ(7) +AC_CHECK_FUNCS([_NSGetEnviron]) + +dnl This is e.g. available as a GNU extension in glibc 2.11+ +AC_CHECK_DECLS([execvpe]) +AC_CHECK_FUNCS([execvpe]) + +AC_CHECK_MEMBERS([struct stat.st_atim]) +AC_CHECK_MEMBERS([struct stat.st_mtim]) +AC_CHECK_MEMBERS([struct stat.st_ctim]) +AC_CHECK_MEMBERS([struct stat.st_atimespec]) +AC_CHECK_MEMBERS([struct stat.st_mtimespec]) +AC_CHECK_MEMBERS([struct stat.st_ctimespec]) +AC_CHECK_MEMBERS([struct stat.st_atimensec]) +AC_CHECK_MEMBERS([struct stat.st_mtimensec]) +AC_CHECK_MEMBERS([struct stat.st_ctimensec]) +AC_CHECK_MEMBERS([struct stat.st_atime_n]) +AC_CHECK_MEMBERS([struct stat.st_mtime_n]) +AC_CHECK_MEMBERS([struct stat.st_ctime_n]) +AC_CHECK_MEMBERS([struct stat.st_uatime]) +AC_CHECK_MEMBERS([struct stat.st_umtime]) +AC_CHECK_MEMBERS([struct stat.st_uctime]) + +AC_CHECK_MEMBER([struct passwd.pw_gecos], [], [AC_DEFINE([HAVE_NO_PASSWD_PW_GECOS],[],[Ignore the pw_gecos member of passwd where it does not exist])], [[#include ]]) + +# Functions for changing file timestamps +AC_CHECK_FUNCS([utimensat futimens]) +AC_CHECK_FUNCS([lutimes futimes]) + +# Additional temp functions +dnl androids bionic doesn't have mkstemps +# We explicilty check for android, as the check AC_CHECK_FUNCS performs returns "yes" for mkstemps +# when targetting android. See similar conditionals for seekdir and telldir. +AS_CASE([$target_os],[*-android*],[AC_CHECK_FUNCS([mkdtemp])],[AC_CHECK_FUNCS([mkstemps mkdtemp])]) + +# Functions for file synchronization and allocation control +AC_CHECK_FUNCS([fsync]) + +# On OSX linking against 'fdatasync' succeeds, but that doesn't pick +# the expected the POSIX 'fdatasync' function. So make sure that we +# also have a function declaration in scope, in addition to being able +# to link against 'fdatasync'. +AC_CHECK_DECLS([fdatasync],[AC_CHECK_FUNCS([fdatasync])]) + + +AC_CHECK_FUNCS([posix_fadvise posix_fallocate]) + +# Some termios(3) functions known to be missing sometimes (see also #55) +AC_CHECK_DECLS([tcdrain],[AC_DEFINE([HAVE_TCDRAIN],[1],[Define to 1 if you have the `tcdrain' function.])],[],[AC_INCLUDES_DEFAULT +#ifdef HAVE_TERMIOS_H +#include +#endif +]) + +AC_CHECK_DECLS([ctermid],[AC_DEFINE([HAVE_CTERMID],[1],[Define to 1 if you have the `ctermid' function.])],[],[AC_INCLUDES_DEFAULT +#ifdef HAVE_TERMIOS_H +#include +#endif +]) + +# Avoid adding rt if absent or unneeded +# shm_open needs -lrt on linux +AC_SEARCH_LIBS(shm_open, rt, [AC_CHECK_FUNCS([shm_open shm_unlink])]) +AS_IF([test "x$ac_cv_search_shm_open" = x-lrt], [EXTRA_LIBS="$EXTRA_LIBS rt"]) + +FP_CHECK_CONSTS([SIGABRT SIGALRM SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_SETMASK SIG_UNBLOCK SIGINFO SIGWINCH], [ +#if HAVE_SIGNAL_H +#include +#endif]) + +AC_MSG_CHECKING([for _SC_GETGR_R_SIZE_MAX]) +AC_EGREP_CPP(we_have_that_sysconf_thing, +[ +#include +#ifdef _SC_GETGR_R_SIZE_MAX +we_have_that_sysconf_thing +#endif +], +[AC_MSG_RESULT([yes]) +AC_DEFINE([HAVE_SC_GETGR_R_SIZE_MAX], [1], [Define to 1 if defines _SC_GETGR_R_SIZE_MAX.])], +[AC_MSG_RESULT([no])]) + +AC_MSG_CHECKING([for _SC_GETPW_R_SIZE_MAX]) +AC_EGREP_CPP(we_have_that_sysconf_thing, +[ +#include +#ifdef _SC_GETPW_R_SIZE_MAX +we_have_that_sysconf_thing +#endif +], +[AC_MSG_RESULT([yes]) +AC_DEFINE([HAVE_SC_GETPW_R_SIZE_MAX], [1], [Define to 1 if defines _SC_GETPW_R_SIZE_MAX.])], +[AC_MSG_RESULT([no])]) + +dnl ---------- usleep ---------- +dnl --- stolen from guile configure --- + +### On some systems usleep has no return value. If it does have one, +### we'd like to return it; otherwise, we'll fake it. +AC_CACHE_CHECK([return type of usleep], fptools_cv_func_usleep_return_type, + [AC_EGREP_HEADER(changequote(<, >)changequote([, ]), + unistd.h, + [fptools_cv_func_usleep_return_type=void], + [fptools_cv_func_usleep_return_type=int])]) +case "$fptools_cv_func_usleep_return_type" in + "void" ) + AC_DEFINE([USLEEP_RETURNS_VOID], [1], [Define if the system headers declare usleep to return void.]) + ;; +esac + +### POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations +### in common use return void. +AC_CACHE_CHECK([return type of unsetenv], fptools_cv_func_unsetenv_return_type, + [AC_EGREP_HEADER(changequote(<, >)changequote([, ]), + stdlib.h, + [fptools_cv_func_unsetenv_return_type=void], + [fptools_cv_func_unsetenv_return_type=int])]) +case "$fptools_cv_func_unsetenv_return_type" in + "void" ) + AC_DEFINE([UNSETENV_RETURNS_VOID], [1], [Define if stdlib.h declares unsetenv to return void.]) + ;; +esac + +dnl On some hosts (e.g. SuSe and Ubuntu Linux) RTLD_NEXT and RTLD_DEFAULT are +dnl not visible without setting _GNU_SOURCE, which we really don't want to. +dnl Also see comments in System/Posix/DynamicLinker/Prim.hsc. +AC_MSG_CHECKING(for RTLD_NEXT from dlfcn.h) +AC_EGREP_CPP(yes, +[ + #include + #ifdef RTLD_NEXT + yes + #endif +], [ + AC_MSG_RESULT(yes) + AC_DEFINE([HAVE_RTLDNEXT], [1], [Define to 1 if we can see RTLD_NEXT in dlfcn.h.]) +], [ + AC_MSG_RESULT(no) + ]) + +AC_MSG_CHECKING(for RTLD_DEFAULT from dlfcn.h) +AC_EGREP_CPP(yes, +[ + #include + #ifdef RTLD_DEFAULT + yes + #endif +], [ + AC_MSG_RESULT(yes) + AC_DEFINE([HAVE_RTLDDEFAULT], [1], [Define to 1 if RTLD_DEFAULT is available.]) +], [ + AC_MSG_RESULT(no) + ]) + +AC_CHECK_FUNCS(openpty,, + AC_CHECK_LIB(util,openpty, + [AC_DEFINE(HAVE_OPENPTY) EXTRA_LIBS="$EXTRA_LIBS util"], + AC_CHECK_LIB(bsd,openpty, [AC_DEFINE(HAVE_OPENPTY) EXTRA_LIBS="$EXTRA_LIBS bsd"]) + ) +) + +AC_MSG_CHECKING(for /dev/ptmx) +if test -r /dev/ptmx +then + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_DEV_PTMX, 1, + [Define if we have /dev/ptmx.]) +else + AC_MSG_RESULT(no) +fi + +AC_MSG_CHECKING(for /dev/ptc) +if test -r /dev/ptc +then + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_DEV_PTC, 1, + [Define if we have /dev/ptc.]) +else + AC_MSG_RESULT(no) +fi + +# Avoid adding dl if absent or unneeded +AC_SEARCH_LIBS([dlopen], [dl], [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"]) + +# -{l,}pthread goo +AC_CANONICAL_TARGET + +AC_SEARCH_LIBS(sem_close, pthread, + [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"], + [AC_MSG_NOTICE([Not found])]) + +AC_SUBST([EXTRA_LIBS]) +AC_CONFIG_FILES([unix.buildinfo]) + +AC_OUTPUT diff --git a/unix/include/HsUnix.h b/unix/include/HsUnix.h new file mode 100644 index 0000000..1cbbeb3 --- /dev/null +++ b/unix/include/HsUnix.h @@ -0,0 +1,120 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2002 + * + * Definitions for package `unix' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +#ifndef HSUNIX_H +#define HSUNIX_H + +#include "HsUnixConfig.h" +#include "HsFFI.h" + +/* ultra-evil... */ +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#include +#include + +#ifdef HAVE_STRING_H +#include +#endif +#ifdef HAVE_SYS_TIMES_H +#include +#endif +#ifdef HAVE_SYS_TIME_H +#include +#endif +#ifdef HAVE_SYS_RESOURCE_H +#include +#endif +#ifdef HAVE_SYS_WAIT_H +#include +#endif +#ifdef HAVE_SYS_STAT_H +#include +#endif +#ifdef HAVE_TIME_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_UTIME_H +#include +#endif +#ifdef HAVE_FCNTL_H +#include +#endif +#ifdef HAVE_LIMITS_H +#include +#endif +#ifdef HAVE_TERMIOS_H +#include +#endif +#ifdef HAVE_SYS_UTSNAME_H +#include +#endif +#ifdef HAVE_PWD_H +#include +#endif +#ifdef HAVE_GRP_H +#include +#endif +#ifdef HAVE_DIRENT_H +#include +#endif + +#if defined(HAVE_BSD_LIBUTIL_H) +#include +#elif defined(HAVE_LIBUTIL_H) +#include +#endif +#ifdef HAVE_PTY_H +#include +#endif +#ifdef HAVE_UTMP_H +#include +#endif + +#include + +#ifdef HAVE_SIGNAL_H +#include +#endif + +/* defined in rts/posix/Signals.c */ +extern HsInt nocldstop; + +/* defined in libc */ +extern char **environ; + +#ifdef HAVE_RTLDNEXT +void *__hsunix_rtldNext (void); +#endif + +#ifdef HAVE_RTLDDEFAULT +void *__hsunix_rtldDefault (void); +#endif + +/* O_SYNC doesn't exist on Mac OS X and (at least some versions of) FreeBSD, +fall back to O_FSYNC, which should be the same */ +#ifndef O_SYNC +# define O_SYNC O_FSYNC +#endif + +// not part of POSIX, hence may not be always defined +#ifndef WCOREDUMP +# define WCOREDUMP(s) 0 +#endif + +// push a SVR4 STREAMS module; do nothing if STREAMS not available +int __hsunix_push_module(int fd, const char *module); + +#endif diff --git a/unix/include/execvpe.h b/unix/include/execvpe.h new file mode 100644 index 0000000..bfc7eb9 --- /dev/null +++ b/unix/include/execvpe.h @@ -0,0 +1,13 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Interface for code in cbits/execvpe.c + ------------------------------------------------------------------------- */ + +#ifndef HSUNIX_EXECVPE_H +#define HSUNIX_EXECVPE_H + +extern int +__hsunix_execvpe(const char *name, char *const argv[], char *const envp[]); + +#endif diff --git a/unix/install-sh b/unix/install-sh new file mode 100755 index 0000000..377bb86 --- /dev/null +++ b/unix/install-sh @@ -0,0 +1,527 @@ +#!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2011-11-20.07; # UTC + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# 'make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. + +nl=' +' +IFS=" "" $nl" + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit=${DOITPROG-} +if test -z "$doit"; then + doit_exec=exec +else + doit_exec=$doit +fi + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. + +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} + +posix_glob='?' +initialize_posix_glob=' + test "$posix_glob" != "?" || { + if (set -f) 2>/dev/null; then + posix_glob= + else + posix_glob=: + fi + } +' + +posix_mkdir= + +# Desired mode of installed file. +mode=0755 + +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog +rmcmd="$rmprog -f" +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +no_target_directory= + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve the last data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -s $stripprog installed files. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -s) stripcmd=$stripprog;; + + -t) dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; + + -T) no_target_directory=true;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift +done + +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + done +fi + +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call 'install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 +fi + +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 + + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; + + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac +fi + +for src +do + # Protect names problematic for 'test' and other utilities. + case $src in + -* | [=\(\)!]) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + dst=$dst_arg + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + if test -n "$no_target_directory"; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dst=$dstdir/`basename "$src"` + dstdir_status=0 + else + # Prefer dirname, but fall back on a substitute if dirname fails. + dstdir=` + (dirname "$dst") 2>/dev/null || + expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$dst" : 'X\(//\)[^/]' \| \ + X"$dst" : 'X\(//\)$' \| \ + X"$dst" : 'X\(/\)' \| . 2>/dev/null || + echo X"$dst" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 + + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; + esac + + eval "$initialize_posix_glob" + + oIFS=$IFS + IFS=/ + $posix_glob set -f + set fnord $dstdir + shift + $posix_glob set +f + IFS=$oIFS + + prefixes= + + for d + do + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + + eval "$initialize_posix_glob" && + $posix_glob set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + $posix_glob set +f && + + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "; # UTC" +# End: diff --git a/unix/prologue.txt b/unix/prologue.txt new file mode 100644 index 0000000..f2c72e5 --- /dev/null +++ b/unix/prologue.txt @@ -0,0 +1 @@ +POSIX functionality. \ No newline at end of file diff --git a/unix/tests/.gitignore b/unix/tests/.gitignore new file mode 100644 index 0000000..eefd6d4 --- /dev/null +++ b/unix/tests/.gitignore @@ -0,0 +1,42 @@ +.hpc*/ +*.o +*.hi +*.comp.std* +*.run.std* +*.eventlog +*.genscript +*.exe +*.interp.stderr +*.interp.stdout + +# specific files +/T1185 +/T3816 +/T8108 +/executeFile001 +/fdReadBuf001 +/fileStatus +/fileStatusByteString +/fileexist01 +/forkprocess01 +/getEnvironment01 +/getEnvironment02 +/getGroupEntryForName +/getUserEntryForName +/libposix/po003.out +/libposix/posix002 +/libposix/posix003 +/libposix/posix004 +/libposix/posix005 +/libposix/posix006 +/libposix/posix009 +/libposix/posix010 +/libposix/posix014 +/processGroup001 +/processGroup002 +/queryfdoption01 +/resourceLimit +/signals001 +/signals002 +/signals004 +/user001 diff --git a/unix/tests/Makefile b/unix/tests/Makefile new file mode 100644 index 0000000..6a0abcf --- /dev/null +++ b/unix/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/unix/tests/T1185.hs b/unix/tests/T1185.hs new file mode 100644 index 0000000..4948417 --- /dev/null +++ b/unix/tests/T1185.hs @@ -0,0 +1,24 @@ +module Main where + +import Control.Concurrent +import System.Posix +import System.IO +import System.Exit + +main = + do putStrLn "running..." + (stdinr, stdinw) <- createPipe + (stdoutr, stdoutw) <- createPipe + pid <- forkProcess $ do hw <- fdToHandle stdoutw + hr <- fdToHandle stdinr + closeFd stdinw + hGetContents hr >>= hPutStr hw + hClose hr + hClose hw + exitImmediately ExitSuccess + threadDelay 100000 + closeFd stdoutw + closeFd stdinw + hr2 <- fdToHandle stdoutr + hGetContents hr2 >>= putStr + getProcessStatus True False pid >>= print diff --git a/unix/tests/T1185.stdout b/unix/tests/T1185.stdout new file mode 100644 index 0000000..7062314 --- /dev/null +++ b/unix/tests/T1185.stdout @@ -0,0 +1,2 @@ +running... +Just (Exited ExitSuccess) diff --git a/unix/tests/T3816.hs b/unix/tests/T3816.hs new file mode 100644 index 0000000..cda272f --- /dev/null +++ b/unix/tests/T3816.hs @@ -0,0 +1,4 @@ +import System.Posix +main = do + getAllGroupEntries >>= print . (>0) . length + getAllGroupEntries >>= print . (>0) . length diff --git a/unix/tests/T3816.stdout b/unix/tests/T3816.stdout new file mode 100644 index 0000000..dbde422 --- /dev/null +++ b/unix/tests/T3816.stdout @@ -0,0 +1,2 @@ +True +True diff --git a/unix/tests/T8108.hs b/unix/tests/T8108.hs new file mode 100644 index 0000000..cf1c764 --- /dev/null +++ b/unix/tests/T8108.hs @@ -0,0 +1,8 @@ +import Control.Monad +import Control.Concurrent +import System.Posix.User + +main = do + void $ forkIO $ forever $ getGroupEntryForID 0 + void $ forkIO $ forever $ getGroupEntryForID 0 + threadDelay (3*1000*1000) diff --git a/unix/tests/all.T b/unix/tests/all.T new file mode 100644 index 0000000..e4d2f5b --- /dev/null +++ b/unix/tests/all.T @@ -0,0 +1,74 @@ + +test('signals001', normal, compile_and_run, ['-package unix -cpp']) +test('signals002', [], compile_and_run, ['-package unix']) +test('fileexist01', normal, compile_and_run, ['-package unix']) + +# test #4512 +test('forkprocess01', extra_ways(['threaded1_ls']), compile_and_run, + ['-package unix']) + +# +# user001 may fail due to this bug in glibc: +# http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647 +# +# Ticket #1487. The glibc implementation of getlogin, which is called by +# getLoginName, requires that a terminal is connected to filedescriptor 0. +# See: https://sourceware.org/git/?p=glibc.git;a=blob;f=sysdeps/unix/getlogin.c +# Therefore we have to omit the 'ghci' way, because it relies on redirecting +# stdin from file. +# +# But getLoginName also fails on GNU/Linux when using a terminal emulator +# that doesn't write login records to /var/run/utmp. Running: +# $ logname +# should print your login name. If it doesn't, the getLoginName test in user001 +# would fail, so we disabled that test. +# +test('user001', omit_ways(['ghci']), compile_and_run, ['-package unix']) +test('resourceLimit', normal, compile_and_run, ['-package unix']) + +x86FreeBsdFail = when(platform('i386-unknown-freebsd'), expect_fail) + +test('queryfdoption01', [omit_ways(['ghci']), x86FreeBsdFail], compile_and_run, + ['-package unix']) +test('getEnvironment01', x86FreeBsdFail, compile_and_run, ['-package unix']) +test('getEnvironment02', x86FreeBsdFail, compile_and_run, ['-package unix']) +test('getGroupEntryForName', [x86FreeBsdFail, exit_code(1)], compile_and_run, + ['-package unix']) +test('getUserEntryForName', [x86FreeBsdFail, exit_code(1)], compile_and_run, + ['-package unix']) + + +test('signals004', normal, compile_and_run, ['-package unix']) + +if ('threaded1' in config.run_ways): + only_threaded_ways = only_ways(['ghci','threaded1','threaded2']) +else: + only_threaded_ways = skip + +test('fdReadBuf001', only_threaded_ways, compile_and_run, ['-package unix']) + +test('fileStatus', + extra_clean(['dir', 'regular', 'link-dir', 'link-regular']), + compile_and_run, + ['-package unix']) + +test('fileStatusByteString', + extra_clean(['dir', 'regular', 'link-dir', 'link-regular']), + compile_and_run, + ['-package unix']) + + +test('T1185', normal, compile_and_run, ['-package unix']) + +# This test fails for me on x86/Linux with a "does not exist" error. +# Running with strace shows it is trying to talk to winbindd (part of +# Samba), so I think the failure has nothing to do with GHC. Also it +# works on a different machine that doesn't have Samba installed. +# --SDM 18/05/2010 +test('T3816', normal, compile_and_run, ['-package unix']) + +test('processGroup001', normal, compile_and_run, ['-package unix']) +test('processGroup002', normal, compile_and_run, ['-package unix']) +test('executeFile001', omit_ways(prof_ways + ['threaded2']), compile_and_run, ['-package unix']) + +test('T8108', normal, compile_and_run, ['-package unix']) diff --git a/unix/tests/executeFile001.hs b/unix/tests/executeFile001.hs new file mode 100644 index 0000000..7a70695 --- /dev/null +++ b/unix/tests/executeFile001.hs @@ -0,0 +1,6 @@ + +import System.Posix.Process + +main :: IO () +main = executeFile "echo" True ["arg1", "ar g2"] Nothing + diff --git a/unix/tests/executeFile001.stdout b/unix/tests/executeFile001.stdout new file mode 100644 index 0000000..9f4111c --- /dev/null +++ b/unix/tests/executeFile001.stdout @@ -0,0 +1 @@ +arg1 ar g2 diff --git a/unix/tests/fdReadBuf001.hs b/unix/tests/fdReadBuf001.hs new file mode 100644 index 0000000..f987c94 --- /dev/null +++ b/unix/tests/fdReadBuf001.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +import System.Posix +import Control.Monad +import Foreign +import Control.Concurrent +import Data.Char +import System.Exit + +size = 10000 +block = 512 + +main = do + (rd,wr) <- createPipe + let bytes = take size (map (fromIntegral.ord) (cycle ['a'..'z'])) + allocaBytes size $ \p -> do + pokeArray p bytes + forkIO $ do r <- fdWriteBuf wr p (fromIntegral size) + when (fromIntegral r /= size) $ error "fdWriteBuf failed" + allocaBytes block $ \p -> do + let loop text = do + r <- fdReadBuf rd p block + let (chunk,rest) = splitAt (fromIntegral r) text + chars <- peekArray (fromIntegral r) p + when (chars /= chunk) $ error $ "mismatch: expected="++show chunk++", found="++show chars + when (null rest) $ exitWith ExitSuccess + loop rest + loop bytes diff --git a/unix/tests/fileStatus.hs b/unix/tests/fileStatus.hs new file mode 100644 index 0000000..7311421 --- /dev/null +++ b/unix/tests/fileStatus.hs @@ -0,0 +1,109 @@ + +-- GHC trac #2969 + +import System.Posix.Files +import System.Posix.Directory +import System.Posix.IO +import Control.Exception as E +import Control.Monad + +main = do + cleanup + fs <- testRegular + ds <- testDir + testSymlink fs ds + cleanup + +regular = "regular" +dir = "dir" +link_regular = "link-regular" +link_dir = "link-dir" + +testRegular = do + createFile regular ownerReadMode + (fs, _) <- getStatus regular + let expected = (False,False,False,True,False,False,False) + actual = snd (statusElements fs) + when (actual /= expected) $ + fail "unexpected file status bits for regular file" + return fs + +testDir = do + createDirectory dir ownerReadMode + (ds, _) <- getStatus dir + let expected = (False,False,False,False,True,False,False) + actual = snd (statusElements ds) + when (actual /= expected) $ + fail "unexpected file status bits for directory" + return ds + +testSymlink fs ds = do + createSymbolicLink regular link_regular + createSymbolicLink dir link_dir + (fs', ls) <- getStatus link_regular + (ds', lds) <- getStatus link_dir + + let expected = (False,False,False,False,False,True,False) + actualF = snd (statusElements ls) + actualD = snd (statusElements lds) + + when (actualF /= expected) $ + fail "unexpected file status bits for symlink to regular file" + + when (actualD /= expected) $ + fail "unexpected file status bits for symlink to directory" + + when (statusElements fs /= statusElements fs') $ + fail "status for a file does not match when it's accessed via a symlink" + + when (statusElements ds /= statusElements ds') $ + fail "status for a directory does not match when it's accessed via a symlink" + +cleanup = do + ignoreIOExceptions $ removeDirectory dir + mapM_ (ignoreIOExceptions . removeLink) + [regular, link_regular, link_dir] + +ignoreIOExceptions io = io `E.catch` + ((\_ -> return ()) :: IOException -> IO ()) + +getStatus f = do + fs <- getFileStatus f + ls <- getSymbolicLinkStatus f + + fd <- openFd f ReadOnly defaultFileFlags + fs' <- getFdStatus fd + + when (statusElements fs /= statusElements fs') $ + fail "getFileStatus and getFdStatus give inconsistent results" + + when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $ + fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results " + ++ "on a file that is not a symbolic link" + + return (fs, ls) + +-- Yay for 20-element tuples! +statusElements fs = (,) + (deviceID fs + ,fileMode fs + ,linkCount fs + ,fileOwner fs + ,fileGroup fs + ,specialDeviceID fs + ,fileSize fs + ,accessTime fs + ,accessTimeHiRes fs + ,modificationTime fs + ,modificationTimeHiRes fs + ,statusChangeTime fs + ,statusChangeTimeHiRes fs + ) + (isBlockDevice fs + ,isCharacterDevice fs + ,isNamedPipe fs + ,isRegularFile fs + ,isDirectory fs + ,isSymbolicLink fs + ,isSocket fs + ) diff --git a/unix/tests/fileStatusByteString.hs b/unix/tests/fileStatusByteString.hs new file mode 100644 index 0000000..0125363 --- /dev/null +++ b/unix/tests/fileStatusByteString.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- GHC trac #2969 + +import System.Posix.ByteString +import Control.Exception as E +import Control.Monad + +main = do + cleanup + fs <- testRegular + ds <- testDir + testSymlink fs ds + cleanup + +regular = "regular2" +dir = "dir2" +link_regular = "link-regular2" +link_dir = "link-dir2" + +testRegular = do + createFile regular ownerReadMode + (fs, _) <- getStatus regular + let expected = (False,False,False,True,False,False,False) + actual = snd (statusElements fs) + when (actual /= expected) $ + fail "unexpected file status bits for regular file" + return fs + +testDir = do + createDirectory dir ownerReadMode + (ds, _) <- getStatus dir + let expected = (False,False,False,False,True,False,False) + actual = snd (statusElements ds) + when (actual /= expected) $ + fail "unexpected file status bits for directory" + return ds + +testSymlink fs ds = do + createSymbolicLink regular link_regular + createSymbolicLink dir link_dir + (fs', ls) <- getStatus link_regular + (ds', lds) <- getStatus link_dir + + let expected = (False,False,False,False,False,True,False) + actualF = snd (statusElements ls) + actualD = snd (statusElements lds) + + when (actualF /= expected) $ + fail "unexpected file status bits for symlink to regular file" + + when (actualD /= expected) $ + fail "unexpected file status bits for symlink to directory" + + when (statusElements fs /= statusElements fs') $ + fail "status for a file does not match when it's accessed via a symlink" + + when (statusElements ds /= statusElements ds') $ + fail "status for a directory does not match when it's accessed via a symlink" + +cleanup = do + ignoreIOExceptions $ removeDirectory dir + mapM_ (ignoreIOExceptions . removeLink) + [regular, link_regular, link_dir] + +ignoreIOExceptions io = io `E.catch` + ((\_ -> return ()) :: IOException -> IO ()) + +getStatus f = do + fs <- getFileStatus f + ls <- getSymbolicLinkStatus f + + fd <- openFd f ReadOnly defaultFileFlags + fs' <- getFdStatus fd + + when (statusElements fs /= statusElements fs') $ + fail "getFileStatus and getFdStatus give inconsistent results" + + when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $ + fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results " + ++ "on a file that is not a symbolic link" + + return (fs, ls) + +-- Yay for 20-element tuples! +statusElements fs = (,) + (deviceID fs + ,fileMode fs + ,linkCount fs + ,fileOwner fs + ,fileGroup fs + ,specialDeviceID fs + ,fileSize fs + ,accessTime fs + ,accessTimeHiRes fs + ,modificationTime fs + ,modificationTimeHiRes fs + ,statusChangeTime fs + ,statusChangeTimeHiRes fs + ) + (isBlockDevice fs + ,isCharacterDevice fs + ,isNamedPipe fs + ,isRegularFile fs + ,isDirectory fs + ,isSymbolicLink fs + ,isSocket fs + ) diff --git a/unix/tests/fileexist01.hs b/unix/tests/fileexist01.hs new file mode 100644 index 0000000..7bddda9 --- /dev/null +++ b/unix/tests/fileexist01.hs @@ -0,0 +1,5 @@ +-- test System.Posix.fileExist +import System.Posix +main = do + fileExist "fileexist01.hs" >>= print + fileExist "does not exist" >>= print diff --git a/unix/tests/fileexist01.stdout b/unix/tests/fileexist01.stdout new file mode 100644 index 0000000..1cc8b5e --- /dev/null +++ b/unix/tests/fileexist01.stdout @@ -0,0 +1,2 @@ +True +False diff --git a/unix/tests/forkprocess01.hs b/unix/tests/forkprocess01.hs new file mode 100644 index 0000000..bc182c5 --- /dev/null +++ b/unix/tests/forkprocess01.hs @@ -0,0 +1,9 @@ +-- Test that we can call exitFailure in a forked process, and have it +-- communicated properly to the parent. +import System.Exit +import System.Posix.Process +main = do + p <- forkProcess $ exitWith (ExitFailure 72) + r <- getProcessStatus True False p + print r + diff --git a/unix/tests/forkprocess01.stdout b/unix/tests/forkprocess01.stdout new file mode 100644 index 0000000..3c10134 --- /dev/null +++ b/unix/tests/forkprocess01.stdout @@ -0,0 +1 @@ +Just (Exited (ExitFailure 72)) diff --git a/unix/tests/getEnvironment01.hs b/unix/tests/getEnvironment01.hs new file mode 100644 index 0000000..fb50fab --- /dev/null +++ b/unix/tests/getEnvironment01.hs @@ -0,0 +1,8 @@ + +-- test for trac #781 (GHCi on x86_64, cannot link to static data in +-- shared libs) + +import System.Posix.Env + +main = getEnvironment >>= (print . (0 <=) . length) + diff --git a/unix/tests/getEnvironment01.stdout b/unix/tests/getEnvironment01.stdout new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/unix/tests/getEnvironment01.stdout @@ -0,0 +1 @@ +True diff --git a/unix/tests/getEnvironment02.hs b/unix/tests/getEnvironment02.hs new file mode 100644 index 0000000..be920df --- /dev/null +++ b/unix/tests/getEnvironment02.hs @@ -0,0 +1,8 @@ + +-- test for trac #781 (GHCi on x86_64, cannot link to static data in +-- shared libs) + +import System.Posix.Env.ByteString + +main = getEnvironment >>= (print . (0 <=) . length) + diff --git a/unix/tests/getEnvironment02.stdout b/unix/tests/getEnvironment02.stdout new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/unix/tests/getEnvironment02.stdout @@ -0,0 +1 @@ +True diff --git a/unix/tests/getGroupEntryForName.hs b/unix/tests/getGroupEntryForName.hs new file mode 100644 index 0000000..bdb4272 --- /dev/null +++ b/unix/tests/getGroupEntryForName.hs @@ -0,0 +1,5 @@ + +import System.Posix.User + +main :: IO () +main = getGroupEntryForName "thisIsNotMeantToExist" >> return () diff --git a/unix/tests/getGroupEntryForName.stderr b/unix/tests/getGroupEntryForName.stderr new file mode 100644 index 0000000..9a2679f --- /dev/null +++ b/unix/tests/getGroupEntryForName.stderr @@ -0,0 +1 @@ +getGroupEntryForName: getGroupEntryForName: does not exist (no such group) diff --git a/unix/tests/getUserEntryForName.hs b/unix/tests/getUserEntryForName.hs new file mode 100644 index 0000000..a31566e --- /dev/null +++ b/unix/tests/getUserEntryForName.hs @@ -0,0 +1,5 @@ + +import System.Posix.User + +main :: IO () +main = getUserEntryForName "thisIsNotMeantToExist" >> return () diff --git a/unix/tests/getUserEntryForName.stderr b/unix/tests/getUserEntryForName.stderr new file mode 100644 index 0000000..0a941d9 --- /dev/null +++ b/unix/tests/getUserEntryForName.stderr @@ -0,0 +1 @@ +getUserEntryForName: getUserEntryForName: does not exist (no such user) diff --git a/unix/tests/libposix/Makefile b/unix/tests/libposix/Makefile new file mode 100644 index 0000000..4ca7751 --- /dev/null +++ b/unix/tests/libposix/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/unix/tests/libposix/all.T b/unix/tests/libposix/all.T new file mode 100644 index 0000000..a3455ab --- /dev/null +++ b/unix/tests/libposix/all.T @@ -0,0 +1,16 @@ +test('posix002', [ reqlib('unix'), omit_ways(prof_ways), fragile_for(16550, ['threaded2']) ], + compile_and_run, ['']) + +# Skip on mingw32: assumes existence of 'pwd' and /tmp +test('posix003', [when(opsys('mingw32'), skip), extra_clean(['po003.out'])], + compile_and_run, ['']) + +test('posix004', [ reqlib('unix') ], compile_and_run, ['']) + +test('posix005', [reqlib('unix') ], compile_and_run, ['']) + +test('posix006', reqlib('unix'), compile_and_run, ['']) +test('posix009', [ omit_ways(threaded_ways), reqlib('unix') ], compile_and_run, ['']) +test('posix010', reqlib('unix'), compile_and_run, ['']) + +test('posix014', [ reqlib('unix') ], compile_and_run, ['']) diff --git a/unix/tests/libposix/posix002.hs b/unix/tests/libposix/posix002.hs new file mode 100644 index 0000000..c5909ab --- /dev/null +++ b/unix/tests/libposix/posix002.hs @@ -0,0 +1,4 @@ +import System.Posix.Process + +main = + executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")]) diff --git a/unix/tests/libposix/posix002.stdout b/unix/tests/libposix/posix002.stdout new file mode 100644 index 0000000..5e17a60 --- /dev/null +++ b/unix/tests/libposix/posix002.stdout @@ -0,0 +1,2 @@ +ONE=1 +TWO=2 diff --git a/unix/tests/libposix/posix003.hs b/unix/tests/libposix/posix003.hs new file mode 100644 index 0000000..b28f9f7 --- /dev/null +++ b/unix/tests/libposix/posix003.hs @@ -0,0 +1,17 @@ + +import Control.Monad +import Data.Char +import System.Exit +import System.IO +import System.Process + +main = do hw <- openFile "po003.out" WriteMode + ph <- runProcess "pwd" [] (Just "/dev") Nothing Nothing (Just hw) Nothing + ec <- waitForProcess ph + hClose hw + unless (ec == ExitSuccess) $ error "pwd failed" + hr <- openFile "po003.out" ReadMode + output <- hGetContents hr + putStrLn ("Got: " ++ show (filter (not . isSpace) output)) + hClose hr + diff --git a/unix/tests/libposix/posix003.stdout b/unix/tests/libposix/posix003.stdout new file mode 100644 index 0000000..5206ef3 --- /dev/null +++ b/unix/tests/libposix/posix003.stdout @@ -0,0 +1 @@ +Got: "/dev" diff --git a/unix/tests/libposix/posix004.hs b/unix/tests/libposix/posix004.hs new file mode 100644 index 0000000..56c16f0 --- /dev/null +++ b/unix/tests/libposix/posix004.hs @@ -0,0 +1,48 @@ + +import System.Exit (ExitCode(..), exitWith) +import System.Posix.Process +import System.Posix.Signals + +main = do test1 + test2 + test3 + test4 + putStrLn "I'm happy." + +test1 = do + -- Force SIGFPE exceptions to not be ignored. Under some + -- circumstances this test will be run with SIGFPE + -- ignored, see #7399 + installHandler sigFPE Default Nothing + forkProcess $ raiseSignal floatingPointException + Just (pid, tc) <- getAnyProcessStatus True False + case tc of + Terminated sig _ | sig == floatingPointException -> return () + _ -> error "unexpected termination cause" + +test2 = do + forkProcess $ exitImmediately (ExitFailure 42) + Just (pid, tc) <- getAnyProcessStatus True False + case tc of + Exited (ExitFailure 42) -> return () + _ -> error "unexpected termination cause (2)" + +test3 = do + forkProcess $ exitImmediately ExitSuccess + Just (pid, tc) <- getAnyProcessStatus True False + case tc of + Exited ExitSuccess -> return () + _ -> error "unexpected termination cause (3)" + +test4 = do + forkProcess $ raiseSignal softwareStop + Just (pid, tc) <- getAnyProcessStatus True True + case tc of + Stopped sig | sig == softwareStop -> do + signalProcess killProcess pid + Just (pid, tc) <- getAnyProcessStatus True True + case tc of + Terminated sig _ | sig == killProcess -> return () + _ -> error "unexpected termination cause (5)" + _ -> error "unexpected termination cause (4)" + diff --git a/unix/tests/libposix/posix004.stdout b/unix/tests/libposix/posix004.stdout new file mode 100644 index 0000000..8ed7ee5 --- /dev/null +++ b/unix/tests/libposix/posix004.stdout @@ -0,0 +1 @@ +I'm happy. diff --git a/unix/tests/libposix/posix005.hs b/unix/tests/libposix/posix005.hs new file mode 100644 index 0000000..91331ff --- /dev/null +++ b/unix/tests/libposix/posix005.hs @@ -0,0 +1,24 @@ +import Data.List (sort) +import System.IO +import System.Posix.Env + +printEnv :: IO () +printEnv = getEnvironment >>= print . sort + +main = do + hSetBuffering stdout NoBuffering + term <- getEnv "TERM" + maybe (return ()) putStrLn term + setEnvironment [("one","1"),("two","2")] + printEnv + setEnv "foo" "bar" True + printEnv + setEnv "foo" "baz" True + printEnv + setEnv "fu" "bar" True + printEnv + unsetEnv "foo" + printEnv + clearEnv + printEnv + diff --git a/unix/tests/libposix/posix005.stdout b/unix/tests/libposix/posix005.stdout new file mode 100644 index 0000000..4f60054 --- /dev/null +++ b/unix/tests/libposix/posix005.stdout @@ -0,0 +1,7 @@ +vt100 +[("one","1"),("two","2")] +[("foo","bar"),("one","1"),("two","2")] +[("foo","baz"),("one","1"),("two","2")] +[("foo","baz"),("fu","bar"),("one","1"),("two","2")] +[("fu","bar"),("one","1"),("two","2")] +[] diff --git a/unix/tests/libposix/posix006.hs b/unix/tests/libposix/posix006.hs new file mode 100644 index 0000000..697e4e6 --- /dev/null +++ b/unix/tests/libposix/posix006.hs @@ -0,0 +1,18 @@ + +import System.Posix.Time +import System.Posix.Unistd +import System.Posix.Signals + +main = do start <- epochTime + blockSignals reservedSignals -- see #4504 + sleep 1 + finish <- epochTime + let slept = finish - start + if slept >= 1 && slept <= 2 + then putStrLn "OK" + else do putStr "Started: " + print start + putStr "Finished: " + print finish + putStr "Slept: " + print slept diff --git a/unix/tests/libposix/posix006.stdout b/unix/tests/libposix/posix006.stdout new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/unix/tests/libposix/posix006.stdout @@ -0,0 +1 @@ +OK diff --git a/unix/tests/libposix/posix009.hs b/unix/tests/libposix/posix009.hs new file mode 100644 index 0000000..067d3a9 --- /dev/null +++ b/unix/tests/libposix/posix009.hs @@ -0,0 +1,15 @@ +import System.Posix.Signals +import System.Posix.Unistd + +main = do + putStrLn "Blocking real time alarms." + blockSignals (addSignal realTimeAlarm reservedSignals) + putStrLn "Scheduling an alarm in 2 seconds..." + scheduleAlarm 2 + putStrLn "Sleeping 5 seconds." + sleep 5 + putStrLn "Woken up" + ints <- getPendingSignals + putStrLn "Checking pending interrupts for RealTimeAlarm" + print (inSignalSet realTimeAlarm ints) + diff --git a/unix/tests/libposix/posix009.stdout b/unix/tests/libposix/posix009.stdout new file mode 100644 index 0000000..d294675 --- /dev/null +++ b/unix/tests/libposix/posix009.stdout @@ -0,0 +1,6 @@ +Blocking real time alarms. +Scheduling an alarm in 2 seconds... +Sleeping 5 seconds. +Woken up +Checking pending interrupts for RealTimeAlarm +True diff --git a/unix/tests/libposix/posix010.hs b/unix/tests/libposix/posix010.hs new file mode 100644 index 0000000..420d210 --- /dev/null +++ b/unix/tests/libposix/posix010.hs @@ -0,0 +1,16 @@ +import System.Posix + +main = do + root <- getUserEntryForName "root" + putStrLn (ue2String root) + root' <- getUserEntryForID (userID root) + putStrLn (ue2String root') + if homeDirectory root == homeDirectory root' && + userShell root == userShell root' + then putStrLn "OK" + else putStrLn "Mismatch" + +ue2String ue = concat [name, ":", show uid, ":", show gid] + where name = userName ue + uid = userID ue + gid = userGroupID ue diff --git a/unix/tests/libposix/posix010.stdout b/unix/tests/libposix/posix010.stdout new file mode 100644 index 0000000..77a5024 --- /dev/null +++ b/unix/tests/libposix/posix010.stdout @@ -0,0 +1,3 @@ +root:0:0 +root:0:0 +OK diff --git a/unix/tests/libposix/posix014.hs b/unix/tests/libposix/posix014.hs new file mode 100644 index 0000000..9d844b2 --- /dev/null +++ b/unix/tests/libposix/posix014.hs @@ -0,0 +1,13 @@ +-- !! Basic pipe usage +module Main (main) where + +import System.Posix + +main = do + (rd, wd) <- createPipe + pid <- forkProcess $ do (str, _) <- fdRead rd 32 + putStrLn str + fdWrite wd "Hi, there - forked child calling" + getProcessStatus True False pid + return () + diff --git a/unix/tests/libposix/posix014.stdout b/unix/tests/libposix/posix014.stdout new file mode 100644 index 0000000..cab0a57 --- /dev/null +++ b/unix/tests/libposix/posix014.stdout @@ -0,0 +1 @@ +Hi, there - forked child calling diff --git a/unix/tests/processGroup001.hs b/unix/tests/processGroup001.hs new file mode 100644 index 0000000..cd9f70b --- /dev/null +++ b/unix/tests/processGroup001.hs @@ -0,0 +1,7 @@ +import System.Posix.Process + +main = do + pgid <- getProcessGroupID + pgid' <- getProcessGroupIDOf =<< getProcessID + putStr "Testing getProcessGroupID == getProcessGroupIDOf =<< getProcessID: " + print $ pgid == pgid' diff --git a/unix/tests/processGroup001.stdout b/unix/tests/processGroup001.stdout new file mode 100644 index 0000000..b9be50f --- /dev/null +++ b/unix/tests/processGroup001.stdout @@ -0,0 +1 @@ +Testing getProcessGroupID == getProcessGroupIDOf =<< getProcessID: True diff --git a/unix/tests/processGroup002.hs b/unix/tests/processGroup002.hs new file mode 100644 index 0000000..c93a416 --- /dev/null +++ b/unix/tests/processGroup002.hs @@ -0,0 +1,21 @@ +import System.Posix.Process + +main = do + pid <- getProcessID + ppid <- getParentProcessID + ppgid <- getProcessGroupIDOf ppid + -- join the parent process + putStr "Testing joinProcessGroup: " + joinProcessGroup ppgid + pgid1 <- getProcessGroupID + print $ ppgid == pgid1 + -- be a leader + putStr "Testing createProcessGroupFor: " + createProcessGroupFor pid + pgid2 <- getProcessGroupID + print $ pid == fromIntegral pgid2 + -- and join the parent again + putStr "Testing setProcessGroupIDOf: " + setProcessGroupIDOf pid ppgid + pgid3 <- getProcessGroupID + print $ ppgid == pgid3 diff --git a/unix/tests/processGroup002.stdout b/unix/tests/processGroup002.stdout new file mode 100644 index 0000000..b9d2409 --- /dev/null +++ b/unix/tests/processGroup002.stdout @@ -0,0 +1,3 @@ +Testing joinProcessGroup: True +Testing createProcessGroupFor: True +Testing setProcessGroupIDOf: True diff --git a/unix/tests/queryfdoption01.hs b/unix/tests/queryfdoption01.hs new file mode 100644 index 0000000..46833c1 --- /dev/null +++ b/unix/tests/queryfdoption01.hs @@ -0,0 +1,11 @@ +import System.Posix.IO +import System.IO + +showNBR = do + v <- System.Posix.IO.queryFdOption 0 System.Posix.IO.NonBlockingRead + putStr $ "NonBlockingRead = " ++ (show v) ++ "\n" + +main = do + showNBR + System.Posix.IO.setFdOption 0 System.Posix.IO.NonBlockingRead True + showNBR diff --git a/unix/tests/queryfdoption01.stdin b/unix/tests/queryfdoption01.stdin new file mode 100644 index 0000000..0e9d79c --- /dev/null +++ b/unix/tests/queryfdoption01.stdin @@ -0,0 +1,3 @@ +You can't fcntl(fd, F_SETFL, O_NONBLOCK) /dev/null on (Open)BSD, +so just supply this dummy file instead of running this test on +/dev/null. diff --git a/unix/tests/queryfdoption01.stdout b/unix/tests/queryfdoption01.stdout new file mode 100644 index 0000000..1ed43b5 --- /dev/null +++ b/unix/tests/queryfdoption01.stdout @@ -0,0 +1,2 @@ +NonBlockingRead = False +NonBlockingRead = True diff --git a/unix/tests/resourceLimit.hs b/unix/tests/resourceLimit.hs new file mode 100644 index 0000000..05e35af --- /dev/null +++ b/unix/tests/resourceLimit.hs @@ -0,0 +1,16 @@ + +-- #2038 + +import System.Posix.Resource + +main :: IO () +main = do + let soft = ResourceLimit 5 + hard = ResourceLimit 10 + setResourceLimit ResourceCPUTime (ResourceLimits soft hard) + r <- getResourceLimit ResourceCPUTime + let (ResourceLimit s) = softLimit r + let (ResourceLimit h) = hardLimit r + putStrLn $ show s + putStrLn $ show h + diff --git a/unix/tests/resourceLimit.stdout b/unix/tests/resourceLimit.stdout new file mode 100644 index 0000000..c3ec801 --- /dev/null +++ b/unix/tests/resourceLimit.stdout @@ -0,0 +1,2 @@ +5 +10 diff --git a/unix/tests/signals001.hs b/unix/tests/signals001.hs new file mode 100644 index 0000000..20c1d89 --- /dev/null +++ b/unix/tests/signals001.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} + +import System.Posix.Signals + +#include "ghcconfig.h" + +main = do + print (testMembers emptySignalSet) + print (testMembers emptyset) + print (testMembers fullSignalSet) + print (testMembers fullset) + +fullset = internalAbort `addSignal` + realTimeAlarm `addSignal` + busError `addSignal` + processStatusChanged `addSignal` + continueProcess `addSignal` + floatingPointException `addSignal` + lostConnection `addSignal` + illegalInstruction `addSignal` + keyboardSignal `addSignal` + killProcess `addSignal` + openEndedPipe `addSignal` + keyboardTermination `addSignal` + segmentationViolation `addSignal` + softwareStop `addSignal` + softwareTermination `addSignal` + keyboardStop `addSignal` + backgroundRead `addSignal` + backgroundWrite `addSignal` + userDefinedSignal1 `addSignal` + userDefinedSignal2 `addSignal` +#if HAVE_SIGPOLL + pollableEvent `addSignal` +#endif + profilingTimerExpired `addSignal` + badSystemCall `addSignal` + breakpointTrap `addSignal` + urgentDataAvailable `addSignal` + virtualTimerExpired `addSignal` + cpuTimeLimitExceeded `addSignal` + fileSizeLimitExceeded `addSignal` + emptySignalSet + +emptyset = internalAbort `deleteSignal` + realTimeAlarm `deleteSignal` + busError `deleteSignal` + processStatusChanged `deleteSignal` + continueProcess `deleteSignal` + floatingPointException `deleteSignal` + lostConnection `deleteSignal` + illegalInstruction `deleteSignal` + keyboardSignal `deleteSignal` + killProcess `deleteSignal` + openEndedPipe `deleteSignal` + keyboardTermination `deleteSignal` + segmentationViolation `deleteSignal` + softwareStop `deleteSignal` + softwareTermination `deleteSignal` + keyboardStop `deleteSignal` + backgroundRead `deleteSignal` + backgroundWrite `deleteSignal` + userDefinedSignal1 `deleteSignal` + userDefinedSignal2 `deleteSignal` +#if HAVE_SIGPOLL + pollableEvent `deleteSignal` +#endif + profilingTimerExpired `deleteSignal` + badSystemCall `deleteSignal` + breakpointTrap `deleteSignal` + urgentDataAvailable `deleteSignal` + virtualTimerExpired `deleteSignal` + cpuTimeLimitExceeded `deleteSignal` + fileSizeLimitExceeded `deleteSignal` + fullSignalSet + +testMembers set = [ + internalAbort `inSignalSet` set, + realTimeAlarm `inSignalSet` set, + busError `inSignalSet` set, + processStatusChanged `inSignalSet` set, + continueProcess `inSignalSet` set, + floatingPointException `inSignalSet` set, + lostConnection `inSignalSet` set, + illegalInstruction `inSignalSet` set, + keyboardSignal `inSignalSet` set, + killProcess `inSignalSet` set, + openEndedPipe `inSignalSet` set, + keyboardTermination `inSignalSet` set, + segmentationViolation `inSignalSet` set, + softwareStop `inSignalSet` set, + softwareTermination `inSignalSet` set, + keyboardStop `inSignalSet` set, + backgroundRead `inSignalSet` set, + backgroundWrite `inSignalSet` set, + userDefinedSignal1 `inSignalSet` set, + userDefinedSignal2 `inSignalSet` set, +#if HAVE_SIGPOLL + pollableEvent `inSignalSet` set, +#endif + profilingTimerExpired `inSignalSet` set, + badSystemCall `inSignalSet` set, + breakpointTrap `inSignalSet` set, + urgentDataAvailable `inSignalSet` set, + virtualTimerExpired `inSignalSet` set, + cpuTimeLimitExceeded `inSignalSet` set, + fileSizeLimitExceeded `inSignalSet` set + ] diff --git a/unix/tests/signals001.stdout b/unix/tests/signals001.stdout new file mode 100644 index 0000000..b90d1f3 --- /dev/null +++ b/unix/tests/signals001.stdout @@ -0,0 +1,4 @@ +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] diff --git a/unix/tests/signals001.stdout-i386-unknown-freebsd b/unix/tests/signals001.stdout-i386-unknown-freebsd new file mode 100644 index 0000000..b90d1f3 --- /dev/null +++ b/unix/tests/signals001.stdout-i386-unknown-freebsd @@ -0,0 +1,4 @@ +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] diff --git a/unix/tests/signals001.stdout-i386-unknown-openbsd b/unix/tests/signals001.stdout-i386-unknown-openbsd new file mode 100644 index 0000000..b90d1f3 --- /dev/null +++ b/unix/tests/signals001.stdout-i386-unknown-openbsd @@ -0,0 +1,4 @@ +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] diff --git a/unix/tests/signals001.stdout-sparc-unknown-openbsd b/unix/tests/signals001.stdout-sparc-unknown-openbsd new file mode 100644 index 0000000..b90d1f3 --- /dev/null +++ b/unix/tests/signals001.stdout-sparc-unknown-openbsd @@ -0,0 +1,4 @@ +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] diff --git a/unix/tests/signals001.stdout-x86_64-unknown-openbsd b/unix/tests/signals001.stdout-x86_64-unknown-openbsd new file mode 100644 index 0000000..b90d1f3 --- /dev/null +++ b/unix/tests/signals001.stdout-x86_64-unknown-openbsd @@ -0,0 +1,4 @@ +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] diff --git a/unix/tests/signals002.hs b/unix/tests/signals002.hs new file mode 100644 index 0000000..b2e6e5e --- /dev/null +++ b/unix/tests/signals002.hs @@ -0,0 +1,15 @@ +import System.Posix +import Control.Concurrent + +-- !!! test blockSignals, raiseSignal, unblockSignals, getPendingSignals + +main = do + blockSignals ( userDefinedSignal1 `addSignal` emptySignalSet ) + raiseSignal userDefinedSignal1 + set <- getPendingSignals + print (userDefinedSignal1 `inSignalSet` set) + m <- newEmptyMVar + installHandler userDefinedSignal1 + (Catch (putStrLn "hello" >> putMVar m ())) Nothing + awaitSignal (Just emptySignalSet) + takeMVar m diff --git a/unix/tests/signals002.stdout b/unix/tests/signals002.stdout new file mode 100644 index 0000000..8e3dc9e --- /dev/null +++ b/unix/tests/signals002.stdout @@ -0,0 +1,2 @@ +True +hello diff --git a/unix/tests/signals004.hs b/unix/tests/signals004.hs new file mode 100644 index 0000000..d822056 --- /dev/null +++ b/unix/tests/signals004.hs @@ -0,0 +1,26 @@ +import Control.Concurrent +import System.Posix +import Control.Monad + +-- signal stress test: threads installing signal handlers while +-- signals are being constantly thrown and caught. + +installers = 50 +-- too many signals overflows the IO manager's pipe buffer, this seems +-- to be the most we can get away with: +sigs = 400 + +main = do + c <- newChan + m <- newEmptyMVar + installHandler sigUSR1 (handler c) Nothing + replicateM_ installers (forkIO $ do replicateM_ 1000 (install c); putMVar m ()) + replicateM_ sigs (forkIO $ raiseSignal sigUSR1) + replicateM_ installers (takeMVar m) + replicateM_ sigs (readChan c) + +handler c = Catch (writeChan c ()) + +install c = do + old <- installHandler sigUSR1 (handler c) Nothing + installHandler sigUSR1 old Nothing diff --git a/unix/tests/user001.hs b/unix/tests/user001.hs new file mode 100644 index 0000000..4b4dd8b --- /dev/null +++ b/unix/tests/user001.hs @@ -0,0 +1,27 @@ +-- test that none of System.Posix.User.get* fail +import Control.Exception as Exception +import System.Posix.User + +check :: Show a => a -> Bool +check a = show a == show a + +p :: Show a => String -> IO a -> IO () +p s m = (do putStr (s ++ ": ") + c <- fmap check m + putStrLn $ if c then "OK" else "I am the pope!") + `Exception.catch` (\e -> putStrLn ("ERROR: " ++ show (e::SomeException))) + +main :: IO () +main = do p "getRealUserID" $ getRealUserID + p "getRealGroupID" $ getRealGroupID + p "getEffectiveUserID" $ getEffectiveUserID + p "getEffectiveGroupID" $ getEffectiveGroupID + p "getGroups" $ getGroups + --p "getLoginName" $ getLoginName + p "getEffectiveUserName" $ getEffectiveUserName + p "getGroupEntryForID" $ getRealGroupID >>= getGroupEntryForID + p "getGroupEntryForName" $ getRealGroupID >>= getGroupEntryForID >>= getGroupEntryForName . groupName + p "getAllGroupEntries" $ getAllGroupEntries + p "getUserEntryForID" $ getRealUserID >>= getUserEntryForID + --p "getUserEntryForName" $ getLoginName >>= getUserEntryForName + p "getAllUserEntries" $ getAllUserEntries diff --git a/unix/tests/user001.stdout b/unix/tests/user001.stdout new file mode 100644 index 0000000..e2e03df --- /dev/null +++ b/unix/tests/user001.stdout @@ -0,0 +1,11 @@ +getRealUserID: OK +getRealGroupID: OK +getEffectiveUserID: OK +getEffectiveGroupID: OK +getGroups: OK +getEffectiveUserName: OK +getGroupEntryForID: OK +getGroupEntryForName: OK +getAllGroupEntries: OK +getUserEntryForID: OK +getAllUserEntries: OK diff --git a/unix/unix.buildinfo.in b/unix/unix.buildinfo.in new file mode 100644 index 0000000..7905249 --- /dev/null +++ b/unix/unix.buildinfo.in @@ -0,0 +1,3 @@ +buildable: @BUILD_PACKAGE_BOOL@ +extra-libraries: @EXTRA_LIBS@ +install-includes: HsUnixConfig.h diff --git a/unix/unix.cabal b/unix/unix.cabal new file mode 100644 index 0000000..5e104fa --- /dev/null +++ b/unix/unix.cabal @@ -0,0 +1,143 @@ +cabal-version: 1.12 +name: unix +version: 2.8.0.0 +-- NOTE: Don't forget to update ./changelog.md + +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +homepage: https://github.com/haskell/unix +bug-reports: https://github.com/haskell/unix/issues +synopsis: POSIX functionality +category: System +build-type: Configure +tested-with: GHC==8.8.* + GHC==8.6.*, + GHC==8.4.*, + GHC==8.2.*, + GHC==8.0.*, + GHC==7.10.*, + GHC==7.8.*, + GHC==7.6.*, + GHC==7.4.* +description: + This package gives you access to the set of operating system + services standardised by + + (or the IEEE Portable Operating System Interface for Computing + Environments - IEEE Std. 1003.1). + . + The package is not supported under Windows. + +extra-source-files: + changelog.md + config.guess + config.sub + configure + configure.ac + include/HsUnix.h + include/HsUnixConfig.h.in + install-sh + unix.buildinfo.in + +extra-tmp-files: + autom4te.cache + config.log + config.status + include/HsUnixConfig.h + unix.buildinfo + +source-repository head + type: git + location: https://github.com/haskell/unix.git + +library + default-language: Haskell2010 + other-extensions: + CApiFFI + CPP + DeriveDataTypeable + InterruptibleFFI + NondecreasingIndentation + RankNTypes + RecordWildCards + Safe + Trustworthy + + if os(windows) + -- This package currently supports neither Cygwin nor MinGW, + -- therefore os(windows) is effectively not supported. + build-depends: unbuildable<0 + buildable: False + + build-depends: + base >= 4.5 && < 4.14, + bytestring >= 0.9.2 && < 0.11, + time >= 1.2 && < 1.10 + + exposed-modules: + System.Posix + System.Posix.ByteString + + System.Posix.Error + System.Posix.Resource + System.Posix.Time + System.Posix.Unistd + System.Posix.User + System.Posix.Signals + System.Posix.Signals.Exts + System.Posix.Semaphore + System.Posix.SharedMem + + System.Posix.ByteString.FilePath + + System.Posix.Directory + System.Posix.Directory.Common + System.Posix.Directory.ByteString + + System.Posix.DynamicLinker.Module + System.Posix.DynamicLinker.Module.ByteString + System.Posix.DynamicLinker.Prim + System.Posix.DynamicLinker.ByteString + System.Posix.DynamicLinker + + System.Posix.Files + System.Posix.Files.ByteString + + System.Posix.IO + System.Posix.IO.ByteString + + System.Posix.Env + System.Posix.Env.ByteString + + System.Posix.Fcntl + + System.Posix.Process + System.Posix.Process.Internals + System.Posix.Process.ByteString + + System.Posix.Temp + System.Posix.Temp.ByteString + + System.Posix.Terminal + System.Posix.Terminal.ByteString + + other-modules: + System.Posix.DynamicLinker.Common + System.Posix.Files.Common + System.Posix.IO.Common + System.Posix.Process.Common + System.Posix.Terminal.Common + + ghc-options: -Wall + + include-dirs: include + includes: + HsUnix.h + execvpe.h + install-includes: + HsUnix.h + execvpe.h + c-sources: + cbits/HsUnix.c + cbits/execvpe.c