Commit 72529f3d authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Backpack'ify System.Posix.Env.


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 40820da5
module Str.ByteString (
Str,
useAsOSString,
newOSString,
packOSString,
module Data.ByteString.Char8
) where
import Foreign.C.String (CString)
import Data.Word (Word8)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Storable
import Data.ByteString.Char8
import Data.ByteString.Unsafe
type Str = ByteString
-- NB: I copypasted this from Str.hsig
-- | Marshal a 'Str' into a NUL terminated C string using temporary
-- storage.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters. However, it may
-- optionally be NUL terminated.
--
-- * the memory is freed when the subcomputation terminates (either
-- normally or via an exception), so the pointer to the temporary
-- storage must /not/ be used after this.
--
useAsOSString :: Str -> (CString -> IO a) -> IO a
-- | Marshal a 'Str' into a NUL terminated C string. However, it may
-- optionally be NUL terminated.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters
--
-- * new storage is allocated for the C string and must be
-- explicitly freed using 'Foreign.Marshal.Alloc.free' or
-- 'Foreign.Marshal.Alloc.finalizerFree'.
--
newOSString :: Str -> IO CString
-- | Marshal a NUL terminated C string into a 'Str'.
--
-- * if 'Str' is Unicode, we will decode using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode
-- otherwise uninterpretable bytes as surrogate sequences,
-- which can be round-tripped back.
--
packOSString :: CString -> IO Str
useAsOSString = useAsCString
newOSString s = unsafeUseAsCStringLen s $ \(c,l) -> do
p <- mallocBytes (l+1)
copyBytes p c (fromIntegral l)
pokeByteOff p l (0::Word8)
return p
packOSString = packCString
{-# LANGUAGE CPP #-}
module Str.String (
Str,
useAsOSString,
newOSString,
packOSString,
break,
tail,
head,
unpack,
append,
pack
) where
import Prelude hiding (break, head, tail)
import qualified Prelude as P
import Foreign.C.String
import System.Posix.Internals
import qualified GHC.Foreign as GHC
import GHC.IO.Encoding (getFileSystemEncoding)
type Str = String
-- NB: I copypasted this from Str.hsig
-- | Marshal a 'Str' into a NUL terminated C string using temporary
-- storage.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters. However, it may
-- optionally be NUL terminated.
--
-- * the memory is freed when the subcomputation terminates (either
-- normally or via an exception), so the pointer to the temporary
-- storage must /not/ be used after this.
--
useAsOSString :: Str -> (CString -> IO a) -> IO a
-- | Marshal a 'Str' into a NUL terminated C string. However, it may
-- optionally be NUL terminated.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters
--
-- * new storage is allocated for the C string and must be
-- explicitly freed using 'Foreign.Marshal.Alloc.free' or
-- 'Foreign.Marshal.Alloc.finalizerFree'.
--
newOSString :: Str -> IO CString
-- | Marshal a NUL terminated C string into a 'Str'.
--
-- * if 'Str' is Unicode, we will decode using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode
-- otherwise uninterpretable bytes as surrogate sequences,
-- which can be round-tripped back.
--
packOSString :: CString -> IO Str
break :: (Char -> Bool) -> Str -> (Str, Str)
tail :: Str -> Str
head :: Str -> Char
unpack :: Str -> String -- or call this toString?
append :: Str -> Str -> Str
pack :: String -> Str
useAsOSString = withFilePath
newOSString = newFilePath
packOSString = peekFilePath
break = P.break
tail = P.tail
head = P.head
unpack = id
append = (++)
pack = id
-- Some internal backwards-compatibility goo.
newFilePath' :: FilePath -> IO CString
newFilePath' fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp
#if !MIN_VERSION_base(4,7,0)
newFilePath :: FilePath -> IO CString
newFilePath = newFilePath'
#endif
signature Str where
import Foreign.C.String (CString)
-- | An abstract, string-like type. It may or may not be Unicode
-- encoded.
data Str
-- Note, all occurrences of 'CString' here are assumed to have
-- the locale 'GHC.IO.Encoding.getFileSystemEncoding';
-- i.e., when decoding into Unicode, it uses PEP 383 to represent otherwise
-- unrepresentable byte sequences.
-- | Marshal a 'Str' into a NUL terminated C string using temporary
-- storage.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters. However, it may
-- optionally be NUL terminated.
--
-- * the memory is freed when the subcomputation terminates (either
-- normally or via an exception), so the pointer to the temporary
-- storage must /not/ be used after this.
--
useAsOSString :: Str -> (CString -> IO a) -> IO a
-- | Marshal a 'Str' into a NUL terminated C string. However, it may
-- optionally be NUL terminated.
--
-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret
-- special use of surrogates as otherwise unrepresentable bytes.
--
-- * the 'Str' may /not/ contain any NUL characters
--
-- * new storage is allocated for the C string and must be
-- explicitly freed using 'Foreign.Marshal.Alloc.free' or
-- 'Foreign.Marshal.Alloc.finalizerFree'.
--
newOSString :: Str -> IO CString
-- | Marshal a NUL terminated C string into a 'Str'.
--
-- * if 'Str' is Unicode, we will decode using PEP 383
-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode
-- otherwise uninterpretable bytes as surrogate sequences,
-- which can be round-tripped back.
--
packOSString :: CString -> IO Str
break :: (Char -> Bool) -> Str -> (Str, Str)
tail :: Str -> Str
head :: Str -> Char
unpack :: Str -> String -- or call this toString?
append :: Str -> Str -> Str
pack :: String -> Str
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI #-}
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
......@@ -14,7 +15,8 @@
-- Stability : provisional
-- Portability : non-portable (requires POSIX)
--
-- POSIX environment support
-- POSIX environment support. Warning: 'setEnvironment' and 'setEnv' are
-- NOT thread-safe.
--
-----------------------------------------------------------------------------
......@@ -32,42 +34,40 @@ module System.Posix.Env (
#include "HsUnix.h"
import Prelude hiding (break, head, tail)
import Str
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types
import Foreign.C.String
import Foreign.C.String (CString)
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
type OSString = CString
-- |'getEnv' looks up a variable in the environment.
getEnv :: String -> IO (Maybe String)
getEnv :: Str -> IO (Maybe Str)
getEnv name = do
litstring <- withFilePath name c_getenv
litstring <- useAsOSString name c_getenv
if litstring /= nullPtr
then liftM Just $ peekFilePath litstring
then liftM Just $ packOSString 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 -> String -> IO String
getEnvDefault :: Str -> Str -> IO Str
getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name)
foreign import ccall unsafe "getenv"
c_getenv :: CString -> IO CString
c_getenv :: OSString -> IO OSString
getEnvironmentPrim :: IO [String]
getEnvironmentPrim :: IO [Str]
getEnvironmentPrim = do
c_environ <- getCEnviron
-- environ can be NULL
......@@ -75,82 +75,107 @@ getEnvironmentPrim = do
then return []
else do
arr <- peekArray0 nullPtr c_environ
mapM peekFilePath arr
mapM packOSString 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
haveNsGetEnviron :: Bool
nsGetEnviron :: IO (Ptr (Ptr OSString))
c_environ_p :: Ptr (Ptr OSString)
#if HAVE__NSGETENVIRON
haveNsGetEnviron = True
nsGetEnviron = nsGetEnviron'
c_environ_p = error "c_environ_p: HAVE__NSGETENVIRON"
foreign import ccall unsafe "_NSGetEnviron"
nsGetEnviron :: IO (Ptr (Ptr CString))
nsGetEnviron' :: IO (Ptr (Ptr OSString))
#else
getCEnviron = peek c_environ_p
haveNsGetEnviron = False
nsGetEnviron = error "nsGetEnviron: !HAVE__NSGETENVIRON"
c_environ_p = c_environ_p'
foreign import ccall unsafe "&environ"
c_environ_p :: Ptr (Ptr CString)
c_environ_p' :: Ptr (Ptr OSString)
#endif
getCEnviron :: IO (Ptr OSString)
-- 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 | haveNsGetEnviron = nsGetEnviron >>= peek
| otherwise = peek c_environ_p
-- |'getEnvironment' retrieves the entire environment as a
-- list of @(key,value)@ pairs.
getEnvironment :: IO [(String,String)]
getEnvironment :: IO [(Str,Str)]
getEnvironment = do
env <- getEnvironmentPrim
return $ map (dropEq.(break ((==) '='))) env
where
dropEq (x,'=':ys) = (x,ys)
dropEq (x,_) = error $ "getEnvironment: insane variable " ++ x
dropEq (x,y)
| head y == '=' = (x,tail y)
| otherwise = error $ "getEnvironment: insane variable " ++ unpack x
-- |'setEnvironment' resets the entire environment to the given list of
-- @(key,value)@ pairs.
setEnvironment :: [(String,String)] -> IO ()
setEnvironment :: [(Str,Str)] -> 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.
haveUnsetEnv :: Bool
unsetEnvReturnsVoid :: Bool
c_unsetenv :: OSString -> IO CInt
c_unsetenv_void :: OSString -> IO ()
unsetEnv :: String -> IO ()
#if HAVE_UNSETENV
haveUnsetEnv = True
# if !UNSETENV_RETURNS_VOID
unsetEnv name = withFilePath name $ \ s ->
throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
unsetEnvReturnsVoid = False
c_unsetenv = c_unsetenv'
c_unsetenv_void = error "c_unsetenv_void: HAVE_UNSETENV && !UNSETENV_RETURNS_VOID"
-- POSIX.1-2001 compliant unsetenv(3)
foreign import capi unsafe "HsUnix.h unsetenv"
c_unsetenv :: CString -> IO CInt
c_unsetenv' :: OSString -> IO CInt
# else
unsetEnv name = withFilePath name c_unsetenv
unsetEnvReturnsVoid = True
c_unsetenv = error "c_unsetenv: HAVE_UNSETENV && UNSETENV_RETURNS_VOID"
c_unsetenv_void = c_unsetenv_void'
-- pre-POSIX unsetenv(3) returning @void@
foreign import capi unsafe "HsUnix.h unsetenv"
c_unsetenv :: CString -> IO ()
c_unsetenv_void' :: OSString -> IO ()
# endif
#else
unsetEnv name = putEnv (name ++ "=")
haveUnsetEnv = False
unsetEnvReturnsVoid = False
c_unsetenv = error "c_unsetenv: !HAVE_UNSETENV"
c_unsetenv_void = error "c_unsetenv_void: !HAVE_UNSETENV"
#endif
-- |The 'unsetEnv' function deletes all instances of the variable name
-- from the environment.
unsetEnv :: Str -> IO ()
unsetEnv name
| haveUnsetEnv && not unsetEnvReturnsVoid
= useAsOSString name $ \ s ->
throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
| haveUnsetEnv && unsetEnvReturnsVoid
= useAsOSString name c_unsetenv_void
| otherwise
= putEnv (append name (pack "="))
-- |'putEnv' function takes an argument of the form @name=value@
-- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
putEnv :: String -> IO ()
putEnv keyvalue = do s <- newFilePath keyvalue
putEnv :: Str -> IO ()
putEnv keyvalue = do s <- newOSString 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
c_putenv :: OSString -> 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
......@@ -159,36 +184,51 @@ foreign import ccall unsafe "putenv"
not reset, otherwise it is reset to the given value.
-}
setEnv :: String -> String -> Bool {-overwrite-} -> IO ()
haveSetEnv :: Bool
c_setenv :: OSString -> OSString -> CInt -> IO CInt
#ifdef HAVE_SETENV
setEnv key value ovrwrt = do
withFilePath key $ \ keyP ->
withFilePath value $ \ valueP ->
throwErrnoIfMinus1_ "setenv" $
c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
haveSetEnv = True
c_setenv = c_setenv'
foreign import ccall unsafe "setenv"
c_setenv :: CString -> CString -> CInt -> IO CInt
c_setenv' :: OSString -> OSString -> 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)
haveSetEnv = False
c_setenv = error "c_setenv: !HAVE_SETENV"
#endif
-- |The 'clearEnv' function clears the environment of all name-value pairs.
clearEnv :: IO ()
setEnv :: Str -> Str -> Bool {-overwrite-} -> IO ()
setEnv key value ovrwrt
| haveSetEnv = do
useAsOSString key $ \ keyP ->
useAsOSString value $ \ valueP ->
throwErrnoIfMinus1_ "setenv" $
c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
| otherwise =
case ovrwrt of
True -> putEnv (key `append` pack "=" `append` value)
False -> do
res <- getEnv key
case res of
Just _ -> return ()
Nothing -> putEnv (key `append` pack "=" `append` value)
haveClearEnv :: Bool
c_clearenv :: IO Int
#if HAVE_CLEARENV
clearEnv = void c_clearenv
haveClearEnv = True
c_clearenv = c_clearenv'
foreign import ccall unsafe "clearenv"
c_clearenv :: IO Int
c_clearenv' :: IO Int
#else
haveClearEnv = False
c_clearenv = error "c_clearenv: !HAVE_CLEARENV"
#endif
-- |The 'clearEnv' function clears the environment of all name-value pairs.
clearEnv :: IO ()
clearEnv | haveClearEnv = void c_clearenv
-- Fallback to 'environ[0] = NULL'.
clearEnv = do
| otherwise = do
c_environ <- getCEnviron
unless (c_environ == nullPtr) $
poke c_environ nullPtr
#endif
......@@ -42,6 +42,42 @@ source-repository head
type: git
location: https://github.com/haskell/unix.git
library impls
default-language: Haskell2010
build-depends:
base >= 4.5 && < 4.10,
time >= 1.2 && < 1.7,
bytestring >= 0.9.2 && < 0.11
hs-source-dirs: impls
exposed-modules:
Str.String
Str.ByteString
library unix-indef
ghc-options: -Wall
build-depends:
base >= 4.5 && < 4.10,
time >= 1.2 && < 1.7
exposed-modules:
System.Posix.Env
hs-source-dirs: unix-indef
required-signatures:
Str
include-dirs: include
includes:
HsUnix.h
execvpe.h
other-extensions:
CApiFFI
CPP
DeriveDataTypeable
InterruptibleFFI
NondecreasingIndentation
RankNTypes
RecordWildCards
Safe
Trustworthy
library
default-language: Haskell2010
other-extensions:
......@@ -64,7 +100,15 @@ library
build-depends:
base >= 4.5 && < 4.10,
bytestring >= 0.9.2 && < 0.11,
time >= 1.2 && < 1.7
time >= 1.2 && < 1.7,
impls,
unix-indef
backpack-includes:
impls,
unix-indef requires (Str as Str.String),
unix-indef (System.Posix.Env as System.Posix.Env.ByteString)
requires (Str as Str.ByteString)
exposed-modules:
System.Posix
......@@ -97,9 +141,6 @@ library
System.Posix.IO
System.Posix.IO.ByteString
System.Posix.Env
System.Posix.Env.ByteString
System.Posix.Fcntl
System.Posix.Process
......@@ -120,6 +161,10 @@ library
System.Posix.Process.Common
System.Posix.Terminal.Common
reexported-modules:
System.Posix.Env,
System.Posix.Env.ByteString
ghc-options: -Wall
include-dirs: include
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment