[PATCH] Provide a raw ByteString version of FilePath and environment APIs
Simon Marlow
marlowsd at gmail.com
Fri Nov 11 17:18:48 CET 2011
The new module System.Posix.ByteString provides exactly the same API
as System.Posix, except that:
- There is a new type: RawFilePath = ByteString
- All functions mentioning FilePath in the System.Posix API
use RawFilePath in the System.Posix.ByteString API
- RawFilePaths are not subject to Unicode locale encoding and
decoding, unlike FilePaths. They are the exact bytes passed to and
returned from the underlying POSIX API.
- Similarly for functions that deal in environment
strings (System.Posix.Env): these use untranslated ByteStrings
in System.Posix.Environment
- There is a new function
System.Posix.ByteString.getArgs :: [ByteString]
returning the raw untranslated arguments as passed to exec() when
the program was started.
---
System/Posix.hs | 8 +-
System/Posix/ByteString.hs | 69 ++
System/Posix/ByteString/FilePath.hsc | 123 ++++
System/Posix/Directory.hsc | 59 +--
System/Posix/Directory/ByteString.hsc | 155 +++++
System/Posix/Directory/Common.hsc | 80 +++
System/Posix/DynamicLinker.hsc | 40 +-
System/Posix/DynamicLinker/ByteString.hsc | 70 ++
System/Posix/DynamicLinker/Common.hsc | 90 +++
System/Posix/DynamicLinker/Module.hsc | 7 +-
System/Posix/DynamicLinker/Module/ByteString.hsc | 77 +++
System/Posix/DynamicLinker/Prim.hsc | 2 +-
System/Posix/Env/ByteString.hsc | 165 +++++
System/Posix/Files.hsc | 337 +----------
System/Posix/Files/ByteString.hsc | 382 +++++++++++
System/Posix/Files/Common.hsc | 408 ++++++++++++
System/Posix/IO.hsc | 400 +-----------
System/Posix/IO/ByteString.hsc | 102 +++
System/Posix/IO/Common.hsc | 465 +++++++++++++
System/Posix/Process.hsc | 334 +----------
System/Posix/Process/ByteString.hsc | 140 ++++
System/Posix/Process/Common.hsc | 405 ++++++++++++
System/Posix/Temp/ByteString.hsc | 82 +++
System/Posix/Terminal.hsc | 710 +-------------------
System/Posix/Terminal/ByteString.hsc | 132 ++++
System/Posix/Terminal/Common.hsc | 764 ++++++++++++++++++++++
tests/all.T | 6 +
tests/fileStatus.hs | 25 +-
tests/getEnvironment02.hs | 8 +
tests/getEnvironment02.stdout | 1 +
unix.cabal | 55 ++-
31 files changed, 3844 insertions(+), 1857 deletions(-)
create mode 100644 System/Posix/ByteString.hs
create mode 100644 System/Posix/ByteString/FilePath.hsc
create mode 100644 System/Posix/Directory/ByteString.hsc
create mode 100644 System/Posix/Directory/Common.hsc
create mode 100644 System/Posix/DynamicLinker/ByteString.hsc
create mode 100644 System/Posix/DynamicLinker/Common.hsc
create mode 100644 System/Posix/DynamicLinker/Module/ByteString.hsc
create mode 100644 System/Posix/Env/ByteString.hsc
create mode 100644 System/Posix/Files/ByteString.hsc
create mode 100644 System/Posix/Files/Common.hsc
create mode 100644 System/Posix/IO/ByteString.hsc
create mode 100644 System/Posix/IO/Common.hsc
create mode 100644 System/Posix/Process/ByteString.hsc
create mode 100644 System/Posix/Process/Common.hsc
create mode 100644 System/Posix/Temp/ByteString.hsc
create mode 100644 System/Posix/Terminal/ByteString.hsc
create mode 100644 System/Posix/Terminal/Common.hsc
create mode 100644 tests/getEnvironment02.hs
create mode 100644 tests/getEnvironment02.stdout
diff --git a/System/Posix.hs b/System/Posix.hs
index ad51792..7ad88a2 100644
--- a/System/Posix.hs
+++ b/System/Posix.hs
@@ -30,7 +30,10 @@ module System.Posix (
module System.Posix.User,
module System.Posix.Resource,
module System.Posix.Semaphore,
- module System.Posix.SharedMem
+ module System.Posix.SharedMem,
+ module System.Posix.DynamicLinker,
+-- XXX 'Module' type clashes with GHC
+-- module System.Posix.DynamicLinker.Module
) where
import System.Posix.Types
@@ -48,6 +51,9 @@ 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
diff --git a/System/Posix/ByteString.hs b/System/Posix/ByteString.hs
new file mode 100644
index 0000000..7ee8bdb
--- /dev/null
+++ b/System/Posix/ByteString.hs
@@ -0,0 +1,69 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Safe #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.ByteString
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at haskell.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- 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/System/Posix/ByteString/FilePath.hsc b/System/Posix/ByteString/FilePath.hsc
new file mode 100644
index 0000000..55cd16a
--- /dev/null
+++ b/System/Posix/ByteString/FilePath.hsc
@@ -0,0 +1,123 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at 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
+import Foreign.C hiding (
+ throwErrnoPath,
+ throwErrnoPathIf,
+ throwErrnoPathIf_,
+ throwErrnoPathIfNull,
+ throwErrnoPathIfMinus1,
+ throwErrnoPathIfMinus1_ )
+
+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/System/Posix/Directory.hsc b/System/Posix/Directory.hsc
index 48e7390..870795b 100644
--- a/System/Posix/Directory.hsc
+++ b/System/Posix/Directory.hsc
@@ -3,9 +3,10 @@
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
+
-----------------------------------------------------------------------------
-- |
--- Module : System.Posix.Files
+-- Module : System.Posix.Directory
-- Copyright : (c) The University of Glasgow 2002
-- License : BSD-style (see the file libraries/base/LICENSE)
--
@@ -13,7 +14,7 @@
-- Stability : provisional
-- Portability : non-portable (requires POSIX)
--
--- POSIX directory support
+-- String-based POSIX directory support
--
-----------------------------------------------------------------------------
@@ -42,6 +43,9 @@ import System.Posix.Error
import System.Posix.Types
import Foreign
import Foreign.C
+
+import System.Posix.Directory.Common
+
#if __GLASGOW_HASKELL__ > 700
import System.Posix.Internals (withFilePath, peekFilePath)
#elif __GLASGOW_HASKELL__ > 611
@@ -70,8 +74,6 @@ createDirectory name mode =
foreign import ccall unsafe "mkdir"
c_mkdir :: CString -> CMode -> IO CInt
-newtype DirStream = DirStream (Ptr CDir)
-
-- | @openDirStream dir@ calls @opendir@ to obtain a
-- directory stream for @dir at .
openDirStream :: FilePath -> IO DirStream
@@ -109,9 +111,6 @@ readDirStream (DirStream dirp) =
then return []
else throwErrno "readDirStream"
-type CDir = ()
-type CDirent = ()
-
-- traversing directories
foreign import ccall unsafe "__hscore_readdir"
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
@@ -122,45 +121,6 @@ foreign import ccall unsafe "__hscore_free_dirent"
foreign import ccall unsafe "__hscore_d_name"
d_name :: Ptr CDirent -> IO CString
--- | @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 at .
-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
-
-seekDirStream :: DirStream -> DirStreamOffset -> IO ()
-seekDirStream (DirStream dirp) (DirStreamOffset off) =
- c_seekdir dirp off
-
-foreign import ccall unsafe "seekdir"
- c_seekdir :: Ptr CDir -> COff -> IO ()
-
-tellDirStream :: DirStream -> IO DirStreamOffset
-tellDirStream (DirStream dirp) = do
- off <- c_telldir dirp
- return (DirStreamOffset off)
-
-foreign import ccall unsafe "telldir"
- c_telldir :: Ptr CDir -> IO COff
-
-{-
- Renamings of functionality provided via Directory interface,
- kept around for b.wards compatibility and for having more POSIXy
- names
--}
-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
-- of the current working directory.
@@ -206,10 +166,3 @@ removeDirectory path =
foreign import ccall unsafe "rmdir"
c_rmdir :: CString -> IO CInt
-
-changeWorkingDirectoryFd :: Fd -> IO ()
-changeWorkingDirectoryFd (Fd fd) =
- throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd)
-
-foreign import ccall unsafe "fchdir"
- c_fchdir :: CInt -> IO CInt
diff --git a/System/Posix/Directory/ByteString.hsc b/System/Posix/Directory/ByteString.hsc
new file mode 100644
index 0000000..9159d05
--- /dev/null
+++ b/System/Posix/Directory/ByteString.hsc
@@ -0,0 +1,155 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at haskell.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- String-based POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Directory.ByteString (
+ -- * Creating and removing directories
+ createDirectory, removeDirectory,
+
+ -- * Reading directories
+ DirStream,
+ openDirStream,
+ readDirStream,
+ rewindDirStream,
+ closeDirStream,
+ DirStreamOffset,
+ tellDirStream,
+ seekDirStream,
+
+ -- * The working dirctory
+ 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 at .
+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 at .
+openDirStream :: RawFilePath -> IO DirStream
+openDirStream name =
+ withFilePath name $ \s -> do
+ dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
+ return (DirStream dirp)
+
+foreign import ccall unsafe "__hsunix_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 = do
+ p <- mallocBytes long_path_size
+ go p long_path_size
+ where go p bytes = do
+ p' <- c_getcwd p (fromIntegral bytes)
+ if p' /= nullPtr
+ then do s <- peekFilePath p'
+ free p'
+ return s
+ else do errno <- getErrno
+ if errno == eRANGE
+ then do let bytes' = bytes * 2
+ p'' <- reallocBytes p bytes'
+ go p'' bytes'
+ else throwErrno "getCurrentDirectory"
+
+foreign import ccall unsafe "getcwd"
+ c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
+
+foreign import ccall unsafe "__hsunix_long_path_size"
+ long_path_size :: Int
+
+-- | @changeWorkingDirectory dir@ calls @chdir@ to change
+-- the current working directory to @dir at .
+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/System/Posix/Directory/Common.hsc b/System/Posix/Directory/Common.hsc
new file mode 100644
index 0000000..9b49357
--- /dev/null
+++ b/System/Posix/Directory/Common.hsc
@@ -0,0 +1,80 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at haskell.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Directory.Common (
+ DirStream(..), CDir, CDirent, DirStreamOffset(..),
+ rewindDirStream,
+ closeDirStream,
+ seekDirStream,
+ tellDirStream,
+ changeWorkingDirectoryFd,
+ ) where
+
+import System.IO.Error
+import System.Posix.Error
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+newtype DirStream = DirStream (Ptr CDir)
+
+type CDir = ()
+type 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 at .
+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
+
+seekDirStream :: DirStream -> DirStreamOffset -> IO ()
+seekDirStream (DirStream dirp) (DirStreamOffset off) =
+ c_seekdir dirp off
+
+foreign import ccall unsafe "seekdir"
+ c_seekdir :: Ptr CDir -> COff -> IO ()
+
+tellDirStream :: DirStream -> IO DirStreamOffset
+tellDirStream (DirStream dirp) = do
+ off <- c_telldir dirp
+ return (DirStreamOffset off)
+
+foreign import ccall unsafe "telldir"
+ c_telldir :: Ptr CDir -> IO COff
+
+changeWorkingDirectoryFd :: Fd -> IO ()
+changeWorkingDirectoryFd (Fd fd) =
+ throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd)
+
+foreign import ccall unsafe "fchdir"
+ c_fchdir :: CInt -> IO CInt
diff --git a/System/Posix/DynamicLinker.hsc b/System/Posix/DynamicLinker.hsc
index ac6efb0..7683fc3 100644
--- a/System/Posix/DynamicLinker.hsc
+++ b/System/Posix/DynamicLinker.hsc
@@ -48,13 +48,14 @@ module System.Posix.DynamicLinker (
where
+import System.Posix.DynamicLinker.Common
+import System.Posix.DynamicLinker.Prim
+
#include "HsUnix.h"
-import System.Posix.DynamicLinker.Prim
-import Control.Exception ( bracket )
+import Control.Exception ( bracket )
import Control.Monad ( liftM )
-import Foreign.Ptr ( Ptr, nullPtr, FunPtr, nullFunPtr )
-import Foreign.C.String
+import Foreign
#if __GLASGOW_HASKELL__ > 611
import System.Posix.Internals ( withFilePath )
#else
@@ -67,39 +68,8 @@ dlopen path flags = do
withFilePath path $ \ p -> do
liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags)
-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 at .
-
-dlsym :: DL -> String -> IO (FunPtr a)
-dlsym source symbol = do
- withCAString symbol $ \ s -> do
- throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s
-
withDL :: String -> [RTLDFlags] -> (DL -> IO a) -> IO a
withDL file flags f = bracket (dlopen file flags) (dlclose) f
withDL_ :: String -> [RTLDFlags] -> (DL -> IO a) -> IO ()
withDL_ file flags f = withDL file flags f >> return ()
-
--- |'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 ()
diff --git a/System/Posix/DynamicLinker/ByteString.hsc b/System/Posix/DynamicLinker/ByteString.hsc
new file mode 100644
index 0000000..6525eb9
--- /dev/null
+++ b/System/Posix/DynamicLinker/ByteString.hsc
@@ -0,0 +1,70 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker.ByteString
+-- Copyright : (c) Volker Stolz <vs at foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs at 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/System/Posix/DynamicLinker/Common.hsc b/System/Posix/DynamicLinker/Common.hsc
new file mode 100644
index 0000000..2b5e0d9
--- /dev/null
+++ b/System/Posix/DynamicLinker/Common.hsc
@@ -0,0 +1,90 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker.Common
+-- Copyright : (c) Volker Stolz <vs at foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs at 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 at .
+
+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/System/Posix/DynamicLinker/Module.hsc b/System/Posix/DynamicLinker/Module.hsc
index c678fed..2e5d6fe 100644
--- a/System/Posix/DynamicLinker/Module.hsc
+++ b/System/Posix/DynamicLinker/Module.hsc
@@ -60,7 +60,8 @@ where
#include "HsUnix.h"
import System.Posix.DynamicLinker
-import Foreign.Ptr ( Ptr, nullPtr, FunPtr )
+import System.Posix.DynamicLinker.Common
+import Foreign.Ptr ( Ptr, nullPtr, FunPtr )
#if __GLASGOW_HASKELL__ > 611
import System.Posix.Internals ( withFilePath )
#else
@@ -70,10 +71,6 @@ withFilePath :: FilePath -> (CString -> IO a) -> IO a
withFilePath = withCString
#endif
--- abstract handle for dynamically loaded module (EXPORTED)
---
-newtype Module = Module (Ptr ())
-
unModule :: Module -> (Ptr ())
unModule (Module adr) = adr
diff --git a/System/Posix/DynamicLinker/Module/ByteString.hsc b/System/Posix/DynamicLinker/Module/ByteString.hsc
new file mode 100644
index 0000000..59f45e2
--- /dev/null
+++ b/System/Posix/DynamicLinker/Module/ByteString.hsc
@@ -0,0 +1,77 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker.Module.ByteString
+-- Copyright : (c) Volker Stolz <vs at foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs at 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/System/Posix/DynamicLinker/Prim.hsc b/System/Posix/DynamicLinker/Prim.hsc
index 2e5409e..9a21d77 100644
--- a/System/Posix/DynamicLinker/Prim.hsc
+++ b/System/Posix/DynamicLinker/Prim.hsc
@@ -30,7 +30,7 @@ module System.Posix.DynamicLinker.Prim (
packRTLDFlags,
RTLDFlags(..),
packDL,
- DL(..)
+ DL(..),
)
where
diff --git a/System/Posix/Env/ByteString.hsc b/System/Posix/Env/ByteString.hsc
new file mode 100644
index 0000000..70b3f73
--- /dev/null
+++ b/System/Posix/Env/ByteString.hsc
@@ -0,0 +1,165 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Env.ByteString
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at 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 -> IO (Maybe ByteString)
+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 -> ByteString -> IO ByteString
+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 darwin_HOST_OS
+-- You should not access _environ directly on Darwin in a bundle/shared library.
+-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+getCEnviron = nsGetEnviron >>= peek
+
+foreign import ccall unsafe "_NSGetEnviron"
+ nsGetEnviron :: IO (Ptr (Ptr CString))
+#else
+getCEnviron = peek c_environ_p
+
+foreign import ccall unsafe "&environ"
+ c_environ_p :: Ptr (Ptr CString)
+#endif
+
+-- |'getEnvironment' retrieves the entire environment as a
+-- list of @(key,value)@ pairs.
+
+getEnvironment :: IO [(ByteString,ByteString)]
+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 -> IO ()
+#ifdef HAVE_UNSETENV
+
+unsetEnv name = B.useAsCString name $ \ s ->
+ throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
+
+foreign import ccall unsafe "__hsunix_unsetenv"
+ c_unsetenv :: CString -> IO CInt
+#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 -> 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 -> ByteString -> 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/System/Posix/Files.hsc b/System/Posix/Files.hsc
index 5606388..5916d1a 100644
--- a/System/Posix/Files.hsc
+++ b/System/Posix/Files.hsc
@@ -89,13 +89,15 @@ module System.Posix.Files (
PathVar(..), getPathVar, getFdPathVar,
) where
+
+import Foreign
+import Foreign.C
+
import System.Posix.Error
import System.Posix.Types
-import System.IO.Unsafe
-import Data.Bits
import System.Posix.Internals
-import Foreign hiding (unsafePerformIO)
-import Foreign.C
+import System.Posix.Files.Common
+
#if __GLASGOW_HASKELL__ > 700
import System.Posix.Internals (withFilePath, peekFilePath)
#elif __GLASGOW_HASKELL__ > 611
@@ -118,114 +120,7 @@ peekFilePathLen = peekCStringLen
#endif
-- -----------------------------------------------------------------------------
--- 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)
+-- chmod()
-- | @setFileMode path mode@ changes permission of the file given by @path@
-- to @mode at . This operation may fail with 'throwErrnoPathIfMinus1_' if @path@
@@ -238,25 +133,6 @@ setFileMode name m =
withFilePath name $ \s -> do
throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
--- | @setFdMode fd mode@ acts like 'setFileMode' but uses a file descriptor
--- @fd@ instead of a 'FilePath'.
---
--- Note: calls @fchmod at .
-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 at .
--- Modes set by this operation are subtracted from files and directories upon
--- creation. The previous file creation mask is returned.
---
--- Note: calls @umask at .
-setFileCreationMask :: FileMode -> IO FileMode
-setFileCreationMask mask = c_umask mask
-
-- -----------------------------------------------------------------------------
-- access()
@@ -298,92 +174,6 @@ access name flags =
then return False
else throwErrnoPath "fileAccess" name
--- -----------------------------------------------------------------------------
--- 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 at .
-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 modification.
-modificationTime :: FileStatus -> EpochTime
--- | Time of last status change (i.e. owner, group, link count, mode, etc.).
-statusChangeTime :: FileStatus -> EpochTime
-
-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)
-
--- | 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
-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID,
-- size, access times, etc.) for the file @path at .
@@ -397,16 +187,6 @@ getFileStatus path = do
throwErrnoPathIfMinus1_ "getFileStatus" path (c_stat s p)
return (FileStatus fp)
--- | @getFdStatus fd@ acts as 'getFileStatus' but uses a file descriptor @fd at .
---
--- Note: calls @fstat at .
-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)
-
-- | 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.
@@ -420,10 +200,10 @@ getSymbolicLinkStatus path = do
throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p)
return (FileStatus fp)
-foreign import ccall unsafe "__hsunix_lstat"
+foreign import ccall unsafe "__hsunix_lstat"
c_lstat :: CString -> Ptr CStat -> IO CInt
--- | @createNamedPipe fifo mode@
+-- | @createNamedPipe fifo mode@
-- creates a new named pipe, @fifo@, with permissions based on
-- @mode at . May fail with 'throwErrnoPathIfMinus1_' if a file named @name@
-- already exists or if the effective user ID of the current process doesn't
@@ -546,17 +326,6 @@ setOwnerAndGroup name uid gid = do
foreign import ccall unsafe "chown"
c_chown :: CString -> CUid -> CGid -> IO CInt
--- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a
--- 'FilePath'.
---
--- Note: calls @fchown at .
-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
-
#if HAVE_LCHOWN
-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus
-- changes permissions on the link itself).
@@ -611,81 +380,9 @@ setFileSize file off =
foreign import ccall unsafe "truncate"
c_truncate :: CString -> COff -> IO CInt
--- | Acts as 'setFileSize' but uses a file descriptor instead of a 'FilePath'.
---
--- Note: calls @ftruncate at .
-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
-
-
-- | @getPathVar var path@ obtains the dynamic value of the requested
-- configurable file limit or option associated with file or directory @path at .
-- For defined file limits, @getPathVar@ returns the associated
@@ -701,19 +398,3 @@ getPathVar name v = do
foreign import ccall unsafe "pathconf"
c_pathconf :: CString -> CInt -> IO CLong
-
-
--- | @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 at . 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 at .
-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/System/Posix/Files/ByteString.hsc b/System/Posix/Files/ByteString.hsc
new file mode 100644
index 0000000..5853ab9
--- /dev/null
+++ b/System/Posix/Files/ByteString.hsc
@@ -0,0 +1,382 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Files.ByteString
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at 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
+-- <http://www.unix.org/version3/online.html> (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,
+ 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, touchFile,
+
+ -- * 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
+
+-- -----------------------------------------------------------------------------
+-- chmod()
+
+-- | @setFileMode path mode@ changes permission of the file given by @path@
+-- to @mode at . 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 at .
+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 at .
+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 at .
+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)
+ then return False
+ else throwErrnoPath "fileAccess" name
+
+
+-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID,
+-- size, access times, etc.) for the file @path at .
+--
+-- Note: calls @stat at .
+getFileStatus :: RawFilePath -> IO FileStatus
+getFileStatus path = do
+ fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+ withForeignPtr fp $ \p ->
+ withFilePath path $ \s ->
+ throwErrnoPathIfMinus1_ "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 at .
+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 ccall unsafe "__hsunix_lstat"
+ c_lstat :: CString -> Ptr CStat -> IO CInt
+
+-- | @createNamedPipe fifo mode@
+-- creates a new named pipe, @fifo@, with permissions based on
+-- @mode at . 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 at .
+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 at .
+createDevice :: RawFilePath -> FileMode -> DeviceID -> IO ()
+createDevice path mode dev =
+ withFilePath path $ \s ->
+ throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev)
+
+foreign import ccall unsafe "__hsunix_mknod"
+ c_mknod :: CString -> CMode -> CDev -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Hard links
+
+-- | @createLink old new@ creates a new path, @new@, linked to an existing file,
+-- @old at .
+--
+-- Note: calls @link at .
+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 at .
+--
+-- Note: calls @unlink at .
+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 at .
+--
+-- 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 at .
+createSymbolicLink :: RawFilePath -> RawFilePath -> IO ()
+createSymbolicLink file1 file2 =
+ withFilePath file1 $ \s1 ->
+ withFilePath file2 $ \s2 ->
+ throwErrnoPathIfMinus1_ "createSymbolicLink" file1 (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 at .
+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 at .
+--
+-- Note: calls @rename at .
+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 at .
+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 at .
+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
+
+-- -----------------------------------------------------------------------------
+-- utime()
+
+-- | @setFileTimes path atime mtime@ sets the access and modification times
+-- associated with file @path@ to @atime@ and @mtime@, respectively.
+--
+-- Note: calls @utime at .
+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)
+
+-- | @touchFile path@ sets the access and modification times associated with
+-- file @path@ to the current time.
+--
+-- Note: calls @utime at .
+touchFile :: RawFilePath -> IO ()
+touchFile name = do
+ withFilePath name $ \s ->
+ throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr)
+
+-- -----------------------------------------------------------------------------
+-- 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 at .
+setFileSize :: RawFilePath -> FileOffset -> IO ()
+setFileSize file off =
+ withFilePath file $ \s ->
+ throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off)
+
+foreign import ccall unsafe "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 at .
+-- 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 at .
+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/System/Posix/Files/Common.hsc b/System/Posix/Files/Common.hsc
new file mode 100644
index 0000000..2894244
--- /dev/null
+++ b/System/Posix/Files/Common.hsc
@@ -0,0 +1,408 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Files.Common
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at 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
+-- <http://www.unix.org/version3/online.html> (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,
+ 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,
+ ) where
+
+import System.Posix.Error
+import System.Posix.Types
+import System.IO.Unsafe
+import Data.Bits
+import System.Posix.Internals
+import Foreign hiding (unsafePerformIO)
+import Foreign.C
+
+-- -----------------------------------------------------------------------------
+-- 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 at .
+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 at .
+-- Modes set by this operation are subtracted from files and directories upon
+-- creation. The previous file creation mask is returned.
+--
+-- Note: calls @umask at .
+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 at .
+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 modification.
+modificationTime :: FileStatus -> EpochTime
+-- | Time of last status change (i.e. owner, group, link count, mode, etc.).
+statusChangeTime :: FileStatus -> EpochTime
+
+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)
+
+-- | 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 at .
+--
+-- Note: calls @fstat at .
+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)
+
+-- -----------------------------------------------------------------------------
+-- fchown()
+
+-- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a
+-- 'FilePath'.
+--
+-- Note: calls @fchown at .
+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 at .
+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 at . 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 at .
+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/System/Posix/IO.hsc b/System/Posix/IO.hsc
index c1a2d0c..c5b8e55 100644
--- a/System/Posix/IO.hsc
+++ b/System/Posix/IO.hsc
@@ -21,6 +21,8 @@
--
-----------------------------------------------------------------------------
+#include "HsUnix.h"
+
module System.Posix.IO (
-- * Input \/ Output
@@ -66,36 +68,9 @@ module System.Posix.IO (
) where
-import System.IO
-import System.IO.Error
import System.Posix.Types
import System.Posix.Error
-import qualified System.Posix.Internals as Base
-
-import Foreign
-import Foreign.C
-import Data.Bits
-
-#ifdef __GLASGOW_HASKELL__
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle
-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)
-#else
-import GHC.IOBase
-import GHC.Handle hiding (fdToHandle)
-import qualified GHC.Handle
-#endif
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude (IOException(..), IOErrorType(..))
-import qualified Hugs.IO (handleToFd, openFd)
-#endif
+import System.Posix.IO.Common
#if __GLASGOW_HASKELL__ > 611
import System.Posix.Internals ( withFilePath )
@@ -104,81 +79,6 @@ withFilePath :: FilePath -> (CString -> IO a) -> IO a
withFilePath = withCString
#endif
-#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
-
--- |Correspond to some of the int flags from C's fcntl.h.
-data OpenFileFlags =
- OpenFileFlags {
- append :: Bool, -- ^ O_APPEND
- exclusive :: Bool, -- ^ O_EXCL
- noctty :: Bool, -- ^ O_NOCTTY
- nonBlock :: Bool, -- ^ O_NONBLOCK
- trunc :: Bool -- ^ O_TRUNC
- }
-
-
--- |Default values for the 'OpenFileFlags' type. False for each of
--- append, exclusive, noctty, nonBlock, and trunc.
-defaultFileFlags :: OpenFileFlags
-defaultFileFlags =
- OpenFileFlags {
- append = False,
- exclusive = False,
- noctty = False,
- nonBlock = False,
- trunc = False
- }
-
-
-- |Open and optionally create this file. See 'System.Posix.Files'
-- for information on how to use the 'FileMode' type.
openFd :: FilePath
@@ -186,32 +86,10 @@ openFd :: FilePath
-> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist.
-> OpenFileFlags
-> IO Fd
-openFd name how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
- nonBlockFlag truncateFlag) = do
- withFilePath name $ \s -> do
- fd <- throwErrnoPathIfMinus1Retry "openFd" name (c_open s 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)
-
- (creat, mode_w) = case maybe_mode of
- Nothing -> (0,0)
- Just x -> ((#const O_CREAT), x)
-
- open_mode = case how of
- ReadOnly -> (#const O_RDONLY)
- WriteOnly -> (#const O_WRONLY)
- ReadWrite -> (#const O_RDWR)
-
-foreign import ccall unsafe "__hscore_open"
- c_open :: CString -> CInt -> CMode -> IO CInt
+openFd name how maybe_mode flags = do
+ withFilePath name $ \str -> do
+ throwErrnoPathIfMinus1Retry "openFd" name $
+ open_ str how maybe_mode flags
-- |Create and open this file in WriteOnly mode. A special case of
-- 'openFd'. See 'System.Posix.Files' for information on how to use
@@ -220,267 +98,3 @@ foreign import ccall unsafe "__hscore_open"
createFile :: FilePath -> FileMode -> IO Fd
createFile name mode
= openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True }
-
--- |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)
-
-foreign import ccall unsafe "HsBase.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").
---
--- GHC only: this function has the side effect of putting the 'Fd'
--- into non-blocking mode (@O_NONBLOCK@) due to the way the standard
--- IO library implements multithreaded I\/O.
---
-fdToHandle :: Fd -> IO Handle
-
-#ifdef __GLASGOW_HASKELL__
-#if __GLASGOW_HASKELL__ >= 611
-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_ at 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))
-
-fdToHandle fd = FD.fdToHandle (fromIntegral fd)
-
-#else
-
-handleToFd h = withHandle "handleToFd" h $ \ h_ -> do
- -- converting a Handle into an Fd effectively means
- -- letting go of the Handle; it is put into a closed
- -- state as a result.
- let fd = haFD h_
- flushWriteBufferOnly h_
- unlockFile (fromIntegral fd)
- -- setting the Handle's fd to (-1) as well as its 'type'
- -- to closed, is enough to disable the finalizer that
- -- eventually is run on the Handle.
- return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd))
-
-fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd)
-#endif
-#endif
-
-#ifdef __HUGS__
-handleToFd h = do
- fd <- Hugs.IO.handleToFd h
- return (fromIntegral fd)
-
-fdToHandle fd = do
- mode <- fdGetMode (fromIntegral fd)
- Hugs.IO.openFd (fromIntegral fd) False mode True
-#endif
-
--- -----------------------------------------------------------------------------
--- 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" (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" (c_fcntl_read fd getflag)
- let r' | val = r .|. opt_val
- | otherwise = r .&. (complement opt_val)
- throwErrnoIfMinus1_ "setFdOption"
- (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
-
-foreign import ccall unsafe "HsBase.h fcntl_read"
- c_fcntl_read :: CInt -> CInt -> IO CInt
-
-foreign import ccall unsafe "HsBase.h fcntl_write"
- c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
-
--- -----------------------------------------------------------------------------
--- 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" (c_fcntl_lock fd (#const F_GETLK) p_flock)
- result <- bytes2ProcessIDAndLock p_flock
- return (maybeResult result)
- where
- maybeResult (_, (Unlock, _, _, _)) = Nothing
- maybeResult x = Just x
-
-type CFLock = ()
-
-foreign import ccall unsafe "HsBase.h fcntl_lock"
- c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
-
-allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a
-allocaLock (lockreq, mode, start, len) io =
- allocaBytes (#const sizeof(struct flock)) $ \p -> do
- (#poke struct flock, l_type) p (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 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" (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"
- (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/System/Posix/IO/ByteString.hsc b/System/Posix/IO/ByteString.hsc
new file mode 100644
index 0000000..518a2ec
--- /dev/null
+++ b/System/Posix/IO/ByteString.hsc
@@ -0,0 +1,102 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -XRecordWildCards #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at 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 Foreign.C hiding (
+ throwErrnoPath,
+ throwErrnoPathIf,
+ throwErrnoPathIf_,
+ throwErrnoPathIfNull,
+ throwErrnoPathIfMinus1,
+ throwErrnoPathIfMinus1_ )
+
+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
+ -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist.
+ -> OpenFileFlags
+ -> IO Fd
+openFd name how maybe_mode flags = do
+ withFilePath name $ \str -> do
+ throwErrnoPathIfMinus1Retry "openFd" name $
+ open_ str how maybe_mode 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 (Just mode) defaultFileFlags{ trunc=True }
diff --git a/System/Posix/IO/Common.hsc b/System/Posix/IO/Common.hsc
new file mode 100644
index 0000000..e4a7671
--- /dev/null
+++ b/System/Posix/IO/Common.hsc
@@ -0,0 +1,465 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -XRecordWildCards #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at 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 System.Posix.Error
+import qualified System.Posix.Internals as Base
+
+import Foreign
+import Foreign.C
+import Data.Bits
+
+#ifdef __GLASGOW_HASKELL__
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle
+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)
+#else
+import GHC.IOBase
+import GHC.Handle hiding (fdToHandle)
+import qualified GHC.Handle
+#endif
+#endif
+
+#ifdef __HUGS__
+import Hugs.Prelude (IOException(..), IOErrorType(..))
+import qualified Hugs.IO (handleToFd, openFd)
+#endif
+
+#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
+
+-- |Correspond to some of the int flags from C's fcntl.h.
+data OpenFileFlags =
+ OpenFileFlags {
+ append :: Bool, -- ^ O_APPEND
+ exclusive :: Bool, -- ^ O_EXCL
+ noctty :: Bool, -- ^ O_NOCTTY
+ nonBlock :: Bool, -- ^ O_NONBLOCK
+ trunc :: Bool -- ^ O_TRUNC
+ }
+
+
+-- |Default values for the 'OpenFileFlags' type. False for each of
+-- append, exclusive, noctty, nonBlock, and trunc.
+defaultFileFlags :: OpenFileFlags
+defaultFileFlags =
+ OpenFileFlags {
+ append = False,
+ exclusive = False,
+ noctty = False,
+ nonBlock = False,
+ trunc = False
+ }
+
+
+-- |Open and optionally create this file. See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+open_ :: CString
+ -> OpenMode
+ -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist.
+ -> OpenFileFlags
+ -> IO Fd
+open_ str how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
+ nonBlockFlag truncateFlag) = 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)
+
+ (creat, mode_w) = case maybe_mode of
+ Nothing -> (0,0)
+ Just x -> ((#const O_CREAT), x)
+
+ open_mode = case how of
+ ReadOnly -> (#const O_RDONLY)
+ WriteOnly -> (#const O_WRONLY)
+ ReadWrite -> (#const O_RDWR)
+
+foreign import ccall unsafe "__hscore_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)
+
+foreign import ccall unsafe "HsBase.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").
+--
+-- GHC only: this function has the side effect of putting the 'Fd'
+-- into non-blocking mode (@O_NONBLOCK@) due to the way the standard
+-- IO library implements multithreaded I\/O.
+--
+fdToHandle :: Fd -> IO Handle
+
+#ifdef __GLASGOW_HASKELL__
+#if __GLASGOW_HASKELL__ >= 611
+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_ at 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))
+
+fdToHandle fd = FD.fdToHandle (fromIntegral fd)
+
+#else
+
+handleToFd h = withHandle "handleToFd" h $ \ h_ -> do
+ -- converting a Handle into an Fd effectively means
+ -- letting go of the Handle; it is put into a closed
+ -- state as a result.
+ let fd = haFD h_
+ flushWriteBufferOnly h_
+ unlockFile (fromIntegral fd)
+ -- setting the Handle's fd to (-1) as well as its 'type'
+ -- to closed, is enough to disable the finalizer that
+ -- eventually is run on the Handle.
+ return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd))
+
+fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd)
+#endif
+#endif
+
+#ifdef __HUGS__
+handleToFd h = do
+ fd <- Hugs.IO.handleToFd h
+ return (fromIntegral fd)
+
+fdToHandle fd = do
+ mode <- fdGetMode (fromIntegral fd)
+ Hugs.IO.openFd (fromIntegral fd) False mode True
+#endif
+
+-- -----------------------------------------------------------------------------
+-- 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" (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" (c_fcntl_read fd getflag)
+ let r' | val = r .|. opt_val
+ | otherwise = r .&. (complement opt_val)
+ throwErrnoIfMinus1_ "setFdOption"
+ (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
+
+foreign import ccall unsafe "HsBase.h fcntl_read"
+ c_fcntl_read :: CInt -> CInt -> IO CInt
+
+foreign import ccall unsafe "HsBase.h fcntl_write"
+ c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- 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" (c_fcntl_lock fd (#const F_GETLK) p_flock)
+ result <- bytes2ProcessIDAndLock p_flock
+ return (maybeResult result)
+ where
+ maybeResult (_, (Unlock, _, _, _)) = Nothing
+ maybeResult x = Just x
+
+type CFLock = ()
+
+foreign import ccall unsafe "HsBase.h fcntl_lock"
+ c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
+
+allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a
+allocaLock (lockreq, mode, start, len) io =
+ allocaBytes (#const sizeof(struct flock)) $ \p -> do
+ (#poke struct flock, l_type) p (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 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" (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"
+ (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/System/Posix/Process.hsc b/System/Posix/Process.hsc
index 57779ce..9b1d72f 100644
--- a/System/Posix/Process.hsc
+++ b/System/Posix/Process.hsc
@@ -70,23 +70,10 @@ module System.Posix.Process (
#include "HsUnix.h"
-import Foreign.C.Error
-import Foreign.C.String
-import Foreign.C.Types
-import Foreign.Marshal.Alloc ( alloca, allocaBytes )
-import Foreign.Marshal.Array ( withArray0 )
-import Foreign.Marshal.Utils ( withMany )
-import Foreign.Ptr ( Ptr, nullPtr )
-import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr )
-import Foreign.Storable ( Storable(..) )
-import System.Exit
+import Foreign
+import Foreign.C
import System.Posix.Process.Internals
-import System.Posix.Types
-import Control.Monad
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.TopHandler ( runIO )
-#endif
+import System.Posix.Process.Common
#if __GLASGOW_HASKELL__ > 611
import System.Posix.Internals ( withFilePath )
@@ -99,216 +86,6 @@ withFilePath = withCString
{-# CFILES cbits/HsUnix.c #-}
#endif
--- -----------------------------------------------------------------------------
--- 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 at .
-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 at .
-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 at .
-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 at .
-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
- })
-
-type CTms = ()
-
-foreign import ccall unsafe "__hsunix_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
-
-#ifdef __GLASGOW_HASKELL__
-{- | '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.
-
-'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.
-
-GHC note: 'forkProcess' is not currently supported when using multiple
-processors (@+RTS -N@), although it is supported with @-threaded@ as
-long as only one processor is being used.
--}
-
-forkProcess :: IO () -> IO ProcessID
-forkProcess action = do
- stable <- newStablePtr (runIO action)
- pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
- freeStablePtr stable
- return pid
-
-foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
-#endif /* __GLASGOW_HASKELL__ */
-
-- | @'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
@@ -356,108 +133,3 @@ foreign import ccall unsafe "execv"
foreign import ccall unsafe "execve"
c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
--- -----------------------------------------------------------------------------
--- 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, because this call might block
-foreign import ccall safe "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, '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.
-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 one 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.
-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 at .
--- The operation never returns.
-exitImmediately :: ExitCode -> IO ()
-exitImmediately exitcode = c_exit (exitcode2Int exitcode)
- where
- exitcode2Int ExitSuccess = 0
- exitcode2Int (ExitFailure n) = fromIntegral n
-
-foreign import ccall unsafe "exit"
- c_exit :: CInt -> IO ()
-
--- -----------------------------------------------------------------------------
--- Deprecated or subject to change
-
-{-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use createProcessGroupFor instead." #-}
--- | @'createProcessGroup' pid@ calls @setpgid@ to make
--- process @pid@ a new process group leader.
--- This function is currently deprecated,
--- and might be changed to making the current
--- process a new process group leader in future versions.
-createProcessGroup :: ProcessID -> IO ProcessGroupID
-createProcessGroup pid = do
- throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
- return pid
-
-{-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use setProcessGroupIdOf instead." #-}
--- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the
--- 'ProcessGroupID' for process @pid@ to @pgid at .
--- This function is currently deprecated,
--- and might be changed to setting the 'ProcessGroupID'
--- for the current process in future versions.
-setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
-setProcessGroupID pid pgid =
- throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
-
--- -----------------------------------------------------------------------------
diff --git a/System/Posix/Process/ByteString.hsc b/System/Posix/Process/ByteString.hsc
new file mode 100644
index 0000000..e7b902e
--- /dev/null
+++ b/System/Posix/Process/ByteString.hsc
@@ -0,0 +1,140 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at 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
+#ifdef __GLASGOW_HASKELL__
+ forkProcess,
+#endif
+ 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
+
+#ifdef __HUGS__
+{-# CFILES cbits/HsUnix.c #-}
+#endif
+
+-- | @'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/System/Posix/Process/Common.hsc b/System/Posix/Process/Common.hsc
new file mode 100644
index 0000000..1e7299f
--- /dev/null
+++ b/System/Posix/Process/Common.hsc
@@ -0,0 +1,405 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Process.Common
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at 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
+#ifdef __GLASGOW_HASKELL__
+ forkProcess,
+#endif
+
+ -- ** 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
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.TopHandler ( runIO )
+#endif
+
+#ifdef __HUGS__
+{-# CFILES cbits/HsUnix.c #-}
+#endif
+
+-- -----------------------------------------------------------------------------
+-- 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 at .
+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 at .
+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 at .
+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 at .
+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
+ })
+
+type CTms = ()
+
+foreign import ccall unsafe "__hsunix_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
+
+#ifdef __GLASGOW_HASKELL__
+{- | '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.
+
+'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.
+
+GHC note: 'forkProcess' is not currently supported when using multiple
+processors (@+RTS -N@), although it is supported with @-threaded@ as
+long as only one processor is being used.
+-}
+
+forkProcess :: IO () -> IO ProcessID
+forkProcess action = do
+ stable <- newStablePtr (runIO action)
+ pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
+ freeStablePtr stable
+ return pid
+
+foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
+#endif /* __GLASGOW_HASKELL__ */
+
+-- -----------------------------------------------------------------------------
+-- 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, because this call might block
+foreign import ccall safe "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, '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.
+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 one 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.
+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 at .
+-- The operation never returns.
+exitImmediately :: ExitCode -> IO ()
+exitImmediately exitcode = c_exit (exitcode2Int exitcode)
+ where
+ exitcode2Int ExitSuccess = 0
+ exitcode2Int (ExitFailure n) = fromIntegral n
+
+foreign import ccall unsafe "exit"
+ c_exit :: CInt -> IO ()
+
+-- -----------------------------------------------------------------------------
+-- Deprecated or subject to change
+
+{-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use createProcessGroupFor instead." #-}
+-- | @'createProcessGroup' pid@ calls @setpgid@ to make
+-- process @pid@ a new process group leader.
+-- This function is currently deprecated,
+-- and might be changed to making the current
+-- process a new process group leader in future versions.
+createProcessGroup :: ProcessID -> IO ProcessGroupID
+createProcessGroup pid = do
+ throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
+ return pid
+
+{-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use setProcessGroupIdOf instead." #-}
+-- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the
+-- 'ProcessGroupID' for process @pid@ to @pgid at .
+-- This function is currently deprecated,
+-- and might be changed to setting the 'ProcessGroupID'
+-- for the current process in future versions.
+setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
+setProcessGroupID pid pgid =
+ throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
+
+-- -----------------------------------------------------------------------------
diff --git a/System/Posix/Temp/ByteString.hsc b/System/Posix/Temp/ByteString.hsc
new file mode 100644
index 0000000..c5f8906
--- /dev/null
+++ b/System/Posix/Temp/ByteString.hsc
@@ -0,0 +1,82 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Temp.ByteString
+-- Copyright : (c) Volker Stolz <vs at foldr.org>
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs at foldr.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- POSIX environment support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Temp.ByteString (
+
+ mkstemp
+
+{- Not ported (yet?):
+ tmpfile: can we handle FILE*?
+ tmpnam: ISO C, should go in base?
+ tempname: dito
+-}
+
+) where
+
+#include "HsUnix.h"
+
+import System.IO (Handle)
+import System.Posix.IO
+import System.Posix.Types
+
+import Foreign.C hiding (
+ throwErrnoPath,
+ throwErrnoPathIf,
+ throwErrnoPathIf_,
+ throwErrnoPathIfNull,
+ throwErrnoPathIfMinus1,
+ throwErrnoPathIfMinus1_ )
+
+import System.Posix.ByteString.FilePath
+
+import Data.ByteString (ByteString)
+
+
+-- |'mkstemp' - make a unique filename and open it for
+-- reading\/writing (only safe on GHC & Hugs).
+-- The returned 'RawFilePath' is the (possibly relative) path of
+-- the created file, which is padded with 6 random characters.
+mkstemp :: ByteString -> IO (RawFilePath, Handle)
+mkstemp template = do
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+ withFilePath template $ \ ptr -> do
+ fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr)
+ name <- peekFilePath ptr
+ h <- fdToHandle (Fd fd)
+ return (name, h)
+#else
+ name <- mktemp (template ++ "XXXXXX")
+ h <- openFile name ReadWriteMode
+ return (name, h)
+
+-- |'mktemp' - make a unique file name
+-- This function should be considered deprecated
+
+mktemp :: ByteString -> IO RawFilePath
+mktemp template = do
+ withFilePath template $ \ ptr -> do
+ ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr)
+ peekFilePath ptr
+
+foreign import ccall unsafe "mktemp"
+ c_mktemp :: CString -> IO CString
+#endif
+
+foreign import ccall unsafe "HsUnix.h __hscore_mkstemp"
+ c_mkstemp :: CString -> IO CInt
+
diff --git a/System/Posix/Terminal.hsc b/System/Posix/Terminal.hsc
index c861a3f..0a2866a 100644
--- a/System/Posix/Terminal.hsc
+++ b/System/Posix/Terminal.hsc
@@ -73,439 +73,31 @@ module System.Posix.Terminal (
#include "HsUnix.h"
-import Data.Bits
-import Data.Char
-import Foreign.C.Error ( errnoToIOError, throwErrnoIfMinus1,
- throwErrnoIfMinus1_, throwErrnoIfNull )
-#ifndef HAVE_PTSNAME
-import Foreign.C.Error ( eNOSYS )
-#endif
-import Foreign.C.String ( CString, peekCString, withCString )
-import Foreign.C.Types
-import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
-import Foreign.Marshal.Alloc ( alloca )
-import Foreign.Marshal.Utils ( copyBytes )
-import Foreign.Ptr ( Ptr, nullPtr, plusPtr )
-import Foreign.Storable ( Storable(..) )
-import System.IO.Error ( ioError )
-import System.IO.Unsafe ( unsafePerformIO )
-import System.Posix.IO ( OpenFileFlags(..), OpenMode(..), defaultFileFlags,
- openFd )
+import Foreign
+import Foreign.C
+import System.Posix.Terminal.Common
import System.Posix.Types
--- -----------------------------------------------------------------------------
--- Terminal attributes
-
-type CTermios = ()
-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
- | MapCRtoLF -- ICRNL
- | IgnoreBreak -- IGNBRK
- | IgnoreCR -- IGNCR
- | IgnoreParityErrors -- IGNPAR
- | MapLFtoCR -- INLCR
- | CheckParity -- INPCK
- | StripHighBit -- ISTRIP
- | StartStopInput -- IXOFF
- | StartStopOutput -- IXON
- | MarkParityErrors -- PARMRK
-
- -- output flags
- | ProcessOutput -- OPOST
- -- ToDo: ONLCR, OCRNL, ONOCR, ONLRET, OFILL,
- -- NLDLY(NL0,NL1), CRDLY(CR0,CR1,CR2,CR2)
- -- TABDLY(TAB0,TAB1,TAB2,TAB3)
- -- BSDLY(BS0,BS1), VTDLY(VT0,VT1), FFDLY(FF0,FF1)
-
- -- control flags
- | LocalMode -- CLOCAL
- | ReadEnable -- CREAD
- | TwoStopBits -- CSTOPB
- | HangupOnClose -- HUPCL
- | EnableParity -- PARENB
- | OddParity -- PARODD
-
- -- local modes
- | EnableEcho -- ECHO
- | EchoErase -- ECHOE
- | EchoKill -- ECHOK
- | EchoLF -- ECHONL
- | ProcessInput -- ICANON
- | ExtendedFunctions -- IEXTEN
- | KeyboardInterrupts -- ISIG
- | NoFlushOnInterrupt -- NOFLSH
- | BackgroundWriteInterrupt -- TOSTOP
-
-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 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 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 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 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 StartStopInput = testInputFlag (#const IXOFF)
-terminalMode StartStopOutput = testInputFlag (#const IXON)
-terminalMode MarkParityErrors = testInputFlag (#const PARMRK)
-terminalMode ProcessOutput = testOutputFlag (#const OPOST)
-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
- = B0
- | B50
- | B75
- | B110
- | B134
- | B150
- | B200
- | B300
- | B600
- | B1200
- | B1800
- | B2400
- | B4800
- | B9600
- | B19200
- | B38400
- | B57600
- | B115200
-
-inputSpeed :: TerminalAttributes -> BaudRate
-inputSpeed termios = unsafePerformIO $ do
- withTerminalAttributes termios $ \p -> do
- w <- c_cfgetispeed p
- return (word2Baud w)
-
-foreign import ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "cfsetospeed"
- c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
-
--- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain
--- the @TerminalAttributes@ associated with @Fd@ @fd at .
-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 ccall unsafe "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 at .
-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 ccall unsafe "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 at .
-sendBreak :: Fd -> Int -> IO ()
-sendBreak (Fd fd) duration
- = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
-
-foreign import ccall unsafe "tcsendbreak"
- c_tcsendbreak :: CInt -> CInt -> IO CInt
-
--- | @drainOutput fd@ calls @tcdrain@ to block until all output
--- written to @Fd@ @fd@ has been transmitted.
-drainOutput :: Fd -> IO ()
-drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
-
-foreign import ccall unsafe "tcdrain"
- c_tcdrain :: CInt -> IO CInt
-
-
-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 at .
-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 ccall unsafe "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 at .
-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 ccall unsafe "tcflow"
- c_tcflow :: CInt -> CInt -> IO CInt
+#if __GLASGOW_HASKELL__ > 700
+import System.Posix.Internals (withFilePath, peekFilePath)
+#elif __GLASGOW_HASKELL__ > 611
+import System.Posix.Internals (withFilePath)
--- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
--- obtain the @ProcessGroupID@ of the foreground process group
--- associated with the terminal attached to @Fd@ @fd at .
-getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
-getTerminalProcessGroupID (Fd fd) = do
- throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
+peekFilePath :: CString -> IO FilePath
+peekFilePath = peekCString
-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 at .
-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
+peekFilePathLen :: CStringLen -> IO FilePath
+peekFilePathLen = peekCStringLen
+#else
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath = withCString
--- | @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
+peekFilePath :: CString -> IO FilePath
+peekFilePath = peekCString
-foreign import ccall unsafe "isatty"
- c_isatty :: CInt -> IO CInt
+peekFilePathLen :: CStringLen -> IO FilePath
+peekFilePathLen = peekCStringLen
+#endif
-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated
-- with the terminal for @Fd@ @fd at . If @fd@ is associated
@@ -514,7 +106,7 @@ foreign import ccall unsafe "isatty"
getTerminalName :: Fd -> IO FilePath
getTerminalName (Fd fd) = do
s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd)
- peekCString s
+ peekFilePath s
foreign import ccall unsafe "ttyname"
c_ttyname :: CInt -> IO CString
@@ -527,7 +119,7 @@ foreign import ccall unsafe "ttyname"
getControllingTerminalName :: IO FilePath
getControllingTerminalName = do
s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr)
- peekCString s
+ peekFilePath s
foreign import ccall unsafe "ctermid"
c_ctermid :: CString -> IO CString
@@ -540,7 +132,7 @@ getSlaveTerminalName :: Fd -> IO FilePath
#ifdef HAVE_PTSNAME
getSlaveTerminalName (Fd fd) = do
s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd)
- peekCString s
+ peekFilePath s
foreign import ccall unsafe "__hsunix_ptsname"
c_ptsname :: CInt -> IO CString
@@ -549,261 +141,3 @@ getSlaveTerminalName _ =
ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing)
#endif
--- | @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
-foreign import ccall unsafe "__hsunix_grantpt"
- c_grantpt :: CInt -> IO CInt
-
-foreign import ccall unsafe "__hsunix_unlockpt"
- c_unlockpt :: CInt -> IO CInt
-#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 */
-
--- -----------------------------------------------------------------------------
--- 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)
-baud2Word B57600 = (#const B57600)
-baud2Word B115200 = (#const B115200)
-
--- And convert a word back to a baud rate
--- We really need some cpp macros here.
-
-word2Baud :: CSpeed -> BaudRate
-word2Baud x =
- if x == (#const B0) then B0
- else if x == (#const B50) then B50
- else if x == (#const B75) then B75
- else if x == (#const B110) then B110
- else if x == (#const B134) then B134
- else if x == (#const B150) then B150
- else if x == (#const B200) then B200
- else if x == (#const B300) then B300
- else if x == (#const B600) then B600
- else if x == (#const B1200) then B1200
- else if x == (#const B1800) then B1800
- else if x == (#const B2400) then B2400
- else if x == (#const B4800) then B4800
- else if x == (#const B9600) then B9600
- else if x == (#const B19200) then B19200
- else if x == (#const B38400) then B38400
- else if x == (#const B57600) then B57600
- else if x == (#const B115200) then B115200
- else 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/System/Posix/Terminal/ByteString.hsc b/System/Posix/Terminal/ByteString.hsc
new file mode 100644
index 0000000..b3ca9a9
--- /dev/null
+++ b/System/Posix/Terminal/ByteString.hsc
@@ -0,0 +1,132 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# 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 at 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
+
+import Foreign.C hiding (
+ throwErrnoPath,
+ throwErrnoPathIf,
+ throwErrnoPathIf_,
+ throwErrnoPathIfNull,
+ throwErrnoPathIfMinus1,
+ throwErrnoPathIfMinus1_ )
+
+import System.Posix.ByteString.FilePath
+
+
+-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated
+-- with the terminal for @Fd@ @fd at . 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.
+getControllingTerminalName :: IO RawFilePath
+getControllingTerminalName = do
+ s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr)
+ peekFilePath s
+
+foreign import ccall unsafe "ctermid"
+ c_ctermid :: CString -> IO CString
+
+-- | @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
+
+foreign import ccall unsafe "__hsunix_ptsname"
+ c_ptsname :: CInt -> IO CString
+#else
+getSlaveTerminalName _ =
+ ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing)
+#endif
+
diff --git a/System/Posix/Terminal/Common.hsc b/System/Posix/Terminal/Common.hsc
new file mode 100644
index 0000000..39a2e30
--- /dev/null
+++ b/System/Posix/Terminal/Common.hsc
@@ -0,0 +1,764 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.Terminal.Common
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at haskell.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- POSIX Terminal support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Terminal.Common (
+ -- * 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,
+
+ -- ** Pseudoterminal operations
+ openPseudoTerminal,
+ ) where
+
+#include "HsUnix.h"
+
+import Data.Bits
+import Data.Char
+import Foreign.C.Error ( errnoToIOError, throwErrnoIfMinus1,
+ throwErrnoIfMinus1_, throwErrnoIfNull )
+#ifndef HAVE_PTSNAME
+import Foreign.C.Error ( eNOSYS )
+#endif
+import Foreign.C.String ( CString, peekCString, withCString )
+import Foreign.C.Types
+import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
+import Foreign.Marshal.Alloc ( alloca )
+import Foreign.Marshal.Utils ( copyBytes )
+import Foreign.Ptr ( Ptr, nullPtr, plusPtr )
+import Foreign.Storable ( Storable(..) )
+import System.IO.Error ( ioError )
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Posix.IO ( OpenFileFlags(..), OpenMode(..), defaultFileFlags,
+ openFd )
+import System.Posix.Types
+
+-- -----------------------------------------------------------------------------
+-- Terminal attributes
+
+type CTermios = ()
+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
+ | MapCRtoLF -- ICRNL
+ | IgnoreBreak -- IGNBRK
+ | IgnoreCR -- IGNCR
+ | IgnoreParityErrors -- IGNPAR
+ | MapLFtoCR -- INLCR
+ | CheckParity -- INPCK
+ | StripHighBit -- ISTRIP
+ | StartStopInput -- IXOFF
+ | StartStopOutput -- IXON
+ | MarkParityErrors -- PARMRK
+
+ -- output flags
+ | ProcessOutput -- OPOST
+ -- ToDo: ONLCR, OCRNL, ONOCR, ONLRET, OFILL,
+ -- NLDLY(NL0,NL1), CRDLY(CR0,CR1,CR2,CR2)
+ -- TABDLY(TAB0,TAB1,TAB2,TAB3)
+ -- BSDLY(BS0,BS1), VTDLY(VT0,VT1), FFDLY(FF0,FF1)
+
+ -- control flags
+ | LocalMode -- CLOCAL
+ | ReadEnable -- CREAD
+ | TwoStopBits -- CSTOPB
+ | HangupOnClose -- HUPCL
+ | EnableParity -- PARENB
+ | OddParity -- PARODD
+
+ -- local modes
+ | EnableEcho -- ECHO
+ | EchoErase -- ECHOE
+ | EchoKill -- ECHOK
+ | EchoLF -- ECHONL
+ | ProcessInput -- ICANON
+ | ExtendedFunctions -- IEXTEN
+ | KeyboardInterrupts -- ISIG
+ | NoFlushOnInterrupt -- NOFLSH
+ | BackgroundWriteInterrupt -- TOSTOP
+
+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 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 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 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 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 StartStopInput = testInputFlag (#const IXOFF)
+terminalMode StartStopOutput = testInputFlag (#const IXON)
+terminalMode MarkParityErrors = testInputFlag (#const PARMRK)
+terminalMode ProcessOutput = testOutputFlag (#const OPOST)
+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
+ = B0
+ | B50
+ | B75
+ | B110
+ | B134
+ | B150
+ | B200
+ | B300
+ | B600
+ | B1200
+ | B1800
+ | B2400
+ | B4800
+ | B9600
+ | B19200
+ | B38400
+ | B57600
+ | B115200
+
+inputSpeed :: TerminalAttributes -> BaudRate
+inputSpeed termios = unsafePerformIO $ do
+ withTerminalAttributes termios $ \p -> do
+ w <- c_cfgetispeed p
+ return (word2Baud w)
+
+foreign import ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "cfsetospeed"
+ c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
+
+-- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain
+-- the @TerminalAttributes@ associated with @Fd@ @fd at .
+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 ccall unsafe "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 at .
+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 ccall unsafe "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 at .
+sendBreak :: Fd -> Int -> IO ()
+sendBreak (Fd fd) duration
+ = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
+
+foreign import ccall unsafe "tcsendbreak"
+ c_tcsendbreak :: CInt -> CInt -> IO CInt
+
+-- | @drainOutput fd@ calls @tcdrain@ to block until all output
+-- written to @Fd@ @fd@ has been transmitted.
+drainOutput :: Fd -> IO ()
+drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
+
+foreign import ccall unsafe "tcdrain"
+ c_tcdrain :: CInt -> IO CInt
+
+
+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 at .
+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 ccall unsafe "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 at .
+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 ccall unsafe "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 at .
+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 at .
+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
+
+-- | @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
+foreign import ccall unsafe "__hsunix_grantpt"
+ c_grantpt :: CInt -> IO CInt
+
+foreign import ccall unsafe "__hsunix_unlockpt"
+ c_unlockpt :: CInt -> IO CInt
+#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 */
+
+-- -----------------------------------------------------------------------------
+-- 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)
+baud2Word B57600 = (#const B57600)
+baud2Word B115200 = (#const B115200)
+
+-- And convert a word back to a baud rate
+-- We really need some cpp macros here.
+
+word2Baud :: CSpeed -> BaudRate
+word2Baud x =
+ if x == (#const B0) then B0
+ else if x == (#const B50) then B50
+ else if x == (#const B75) then B75
+ else if x == (#const B110) then B110
+ else if x == (#const B134) then B134
+ else if x == (#const B150) then B150
+ else if x == (#const B200) then B200
+ else if x == (#const B300) then B300
+ else if x == (#const B600) then B600
+ else if x == (#const B1200) then B1200
+ else if x == (#const B1800) then B1800
+ else if x == (#const B2400) then B2400
+ else if x == (#const B4800) then B4800
+ else if x == (#const B9600) then B9600
+ else if x == (#const B19200) then B19200
+ else if x == (#const B38400) then B38400
+ else if x == (#const B57600) then B57600
+ else if x == (#const B115200) then B115200
+ else 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/tests/all.T b/tests/all.T
index 0086949..c4e2e2c 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -26,6 +26,7 @@ if config.platform == 'i386-unknown-freebsd':
test('queryfdoption01', compose(omit_ways(['ghci']), compose(only_compiler_types(['ghc']), conf)),
compile_and_run, ['-package unix'])
test('getEnvironment01', conf, compile_and_run, ['-package unix'])
+test('getEnvironment02', conf, compile_and_run, ['-package unix'])
test('getGroupEntryForName', compose(conf, exit_code(1)), compile_and_run,
['-package unix'])
test('getUserEntryForName', compose(conf, exit_code(1)), compile_and_run,
@@ -46,6 +47,11 @@ test('fileStatus',
compile_and_run,
['-package unix'])
+test('fileStatusByteString',
+ extra_clean(['dir', 'regular', 'link-dir', 'link-regular']),
+ compile_and_run,
+ ['-package unix'])
+
test('1185', [ expect_fail_for(['threaded2']) ],
compile_and_run, ['-package unix'])
diff --git a/tests/fileStatus.hs b/tests/fileStatus.hs
index a393d72..e1d1661 100644
--- a/tests/fileStatus.hs
+++ b/tests/fileStatus.hs
@@ -14,9 +14,14 @@ main = do
testSymlink fs ds
cleanup
+regular = "regular"
+dir = "dir"
+link_regular = "link-regular"
+link_dir = "link-dir"
+
testRegular = do
- createFile "regular" ownerReadMode
- (fs, _) <- getStatus "regular"
+ createFile regular ownerReadMode
+ (fs, _) <- getStatus regular
let expected = (False,False,False,True,False,False,False)
actual = snd (statusElements fs)
when (actual /= expected) $
@@ -24,8 +29,8 @@ testRegular = do
return fs
testDir = do
- createDirectory "dir" ownerReadMode
- (ds, _) <- getStatus "dir"
+ createDirectory dir ownerReadMode
+ (ds, _) <- getStatus dir
let expected = (False,False,False,False,True,False,False)
actual = snd (statusElements ds)
when (actual /= expected) $
@@ -33,10 +38,10 @@ testDir = do
return ds
testSymlink fs ds = do
- createSymbolicLink "regular" "link-regular"
- createSymbolicLink "dir" "link-dir"
- (fs', ls) <- getStatus "link-regular"
- (ds', lds) <- getStatus "link-dir"
+ 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)
@@ -55,9 +60,9 @@ testSymlink fs ds = do
fail "status for a directory does not match when it's accessed via a symlink"
cleanup = do
- ignoreIOExceptions $ removeDirectory "dir"
+ ignoreIOExceptions $ removeDirectory dir
mapM_ (ignoreIOExceptions . removeLink)
- ["regular", "link-regular", "link-dir"]
+ [regular, link_regular, link_dir]
ignoreIOExceptions io = io `E.catch`
((\_ -> return ()) :: IOException -> IO ())
diff --git a/tests/getEnvironment02.hs b/tests/getEnvironment02.hs
new file mode 100644
index 0000000..be920df
--- /dev/null
+++ b/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/tests/getEnvironment02.stdout b/tests/getEnvironment02.stdout
new file mode 100644
index 0000000..0ca9514
--- /dev/null
+++ b/tests/getEnvironment02.stdout
@@ -0,0 +1 @@
+True
diff --git a/unix.cabal b/unix.cabal
index a6f95e4..d07f043 100644
--- a/unix.cabal
+++ b/unix.cabal
@@ -27,19 +27,10 @@ Cabal-Version: >= 1.6
Library
exposed-modules:
System.Posix
- System.Posix.DynamicLinker.Module
- System.Posix.DynamicLinker.Prim
- System.Posix.Directory
- System.Posix.DynamicLinker
- System.Posix.Env
+ System.Posix.ByteString
+
System.Posix.Error
- System.Posix.Files
- System.Posix.IO
- System.Posix.Process
- System.Posix.Process.Internals
System.Posix.Resource
- System.Posix.Temp
- System.Posix.Terminal
System.Posix.Time
System.Posix.Unistd
System.Posix.User
@@ -47,7 +38,47 @@ Library
System.Posix.Signals.Exts
System.Posix.Semaphore
System.Posix.SharedMem
- build-depends: base >= 4.2 && < 4.5
+
+ System.Posix.ByteString.FilePath
+
+ System.Posix.Directory
+ System.Posix.Directory.ByteString
+
+ System.Posix.DynamicLinker.Module
+ System.Posix.DynamicLinker.Module.ByteString
+ System.Posix.DynamicLinker.Prim
+ System.Posix.DynamicLinker.Common
+ 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.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.Directory.Common
+ System.Posix.Files.Common
+ System.Posix.IO.Common
+ System.Posix.Process.Common
+ System.Posix.Terminal.Common
+
+ build-depends: base >= 4.2 && < 4.5,
+ bytestring >= 0.9.2.0 && < 0.10
extensions: CPP, ForeignFunctionInterface, EmptyDataDecls
if impl(ghc >= 7.1)
extensions: NondecreasingIndentation
--
1.7.0.4
--------------080006050501030508060905--
More information about the Libraries
mailing list