Some some

This commit is contained in:
Julian Ospald 2020-04-14 11:27:28 +02:00
parent e194fdec91
commit eea53e7113
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
123 changed files with 14143 additions and 18 deletions

View File

@ -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

View File

@ -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

View File

@ -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.

31
unix/LICENSE Normal file
View File

@ -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.

15
unix/README.md Normal file
View File

@ -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.

6
unix/Setup.hs Normal file
View File

@ -0,0 +1,6 @@
module Main (main) where
import Distribution.Simple
main :: IO ()
main = defaultMainWithHooks autoconfUserHooks

189
unix/System/Posix.hs Normal file
View File

@ -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)
--
-- <http://pubs.opengroup.org/onlinepubs/9699919799/ POSIX.1-2008> 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
-}

View File

@ -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)
--
-- <http://pubs.opengroup.org/onlinepubs/9699919799/ POSIX.1-2008>
-- 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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -0,0 +1,72 @@
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.DynamicLinker
-- Copyright : (c) Volker Stolz <vs@foldr.org> 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 ()

View File

@ -0,0 +1,73 @@
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.DynamicLinker.ByteString
-- Copyright : (c) Volker Stolz <vs@foldr.org> 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 ()

View File

@ -0,0 +1,92 @@
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.DynamicLinker.Common
-- Copyright : (c) Volker Stolz <vs@foldr.org> 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 ())

View File

@ -0,0 +1,121 @@
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.DynamicLinker.Module
-- Copyright : (c) Volker Stolz <vs@foldr.org> 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 ()

View File

@ -0,0 +1,79 @@
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.DynamicLinker.Module.ByteString
-- Copyright : (c) Volker Stolz <vs@foldr.org> 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

View File

@ -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 <vs@foldr.org> 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

205
unix/System/Posix/Env.hsc Normal file
View File

@ -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