Provide a raw ByteString version of FilePath and environment APIs
authorSimon Marlow <marlowsd@gmail.com>
Fri, 11 Nov 2011 16:18:48 +0000 (16:18 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Tue, 22 Nov 2011 12:36:48 +0000 (12:36 +0000)
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.

32 files changed:
System/Posix.hs
System/Posix/ByteString.hs [new file with mode: 0644]
System/Posix/ByteString/FilePath.hsc [new file with mode: 0644]
System/Posix/Directory.hsc
System/Posix/Directory/ByteString.hsc [new file with mode: 0644]
System/Posix/Directory/Common.hsc [new file with mode: 0644]
System/Posix/DynamicLinker.hsc
System/Posix/DynamicLinker/ByteString.hsc [new file with mode: 0644]
System/Posix/DynamicLinker/Common.hsc [new file with mode: 0644]
System/Posix/DynamicLinker/Module.hsc
System/Posix/DynamicLinker/Module/ByteString.hsc [new file with mode: 0644]
System/Posix/DynamicLinker/Prim.hsc
System/Posix/Env/ByteString.hsc [new file with mode: 0644]
System/Posix/Files.hsc
System/Posix/Files/ByteString.hsc [new file with mode: 0644]
System/Posix/Files/Common.hsc [new file with mode: 0644]
System/Posix/IO.hsc
System/Posix/IO/ByteString.hsc [new file with mode: 0644]
System/Posix/IO/Common.hsc [new file with mode: 0644]
System/Posix/Process.hsc
System/Posix/Process/ByteString.hsc [new file with mode: 0644]
System/Posix/Process/Common.hsc [new file with mode: 0644]
System/Posix/Temp/ByteString.hsc [new file with mode: 0644]
System/Posix/Terminal.hsc
System/Posix/Terminal/ByteString.hsc [new file with mode: 0644]
System/Posix/Terminal/Common.hsc [new file with mode: 0644]
tests/all.T
tests/fileStatus.hs
tests/fileStatusByteString.hs [new file with mode: 0644]
tests/getEnvironment02.hs [new file with mode: 0644]
tests/getEnvironment02.stdout [new file with mode: 0644]
unix.cabal

index ad51792..7ad88a2 100644 (file)
@@ -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 (file)
index 0000000..7ee8bdb
--- /dev/null
@@ -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@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 (file)
index 0000000..55cd16a
--- /dev/null
@@ -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@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)
index 48e7390..870795b 100644 (file)
@@ -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@.
 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@.
-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 (file)
index 0000000..9159d05
--- /dev/null
@@ -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@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@.
+createDirectory :: RawFilePath -> FileMode -> IO ()
+createDirectory name mode =
+  withFilePath name $ \s -> 
+    throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode)  
+    -- POSIX doesn't allow mkdir() to return EINTR, but it does on
+    -- OS X (#5184), so we need the Retry variant here.
+
+foreign import ccall unsafe "mkdir"
+  c_mkdir :: CString -> CMode -> IO CInt
+
+-- | @openDirStream dir@ calls @opendir@ to obtain a
+--   directory stream for @dir@.
+openDirStream :: RawFilePath -> IO DirStream
+openDirStream name =
+  withFilePath name $ \s -> do
+    dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
+    return (DirStream dirp)
+
+foreign import 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@.
+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 (file)
index 0000000..9b49357
--- /dev/null
@@ -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@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@.
+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
index ac6efb0..7683fc3 100644 (file)
@@ -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@.
-
-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 (file)
index 0000000..6525eb9
--- /dev/null
@@ -0,0 +1,70 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.ByteString (
+
+    module System.Posix.DynamicLinker.Prim,
+    dlopen,
+    dlsym,
+    dlerror,
+    dlclose,
+    withDL, withDL_,
+    undl,
+    )
+
+--  Usage:
+--  ******
+--  
+--  Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+--  offering a function
+--    @char \* mogrify (char\*,int)@
+--  and invoke @str = mogrify("test",1)@:
+-- 
+--  
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+-- 
+--  withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+--     funptr <- dlsym mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" \$ \\ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+--  
+
+where
+
+import System.Posix.DynamicLinker.Common
+import System.Posix.DynamicLinker.Prim
+
+#include "HsUnix.h"
+
+import Control.Exception        ( bracket )
+import Control.Monad   ( liftM )
+import Foreign
+import System.Posix.ByteString.FilePath
+
+dlopen :: RawFilePath -> [RTLDFlags] -> IO DL
+dlopen path flags = do
+  withFilePath path $ \ p -> do
+    liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags)
+
+withDL :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a
+withDL file flags f = bracket (dlopen file flags) (dlclose) f
+
+withDL_ :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO ()
+withDL_ file flags f = withDL file flags f >> return ()
diff --git a/System/Posix/DynamicLinker/Common.hsc b/System/Posix/DynamicLinker/Common.hsc
new file mode 100644 (file)
index 0000000..2b5e0d9
--- /dev/null
@@ -0,0 +1,90 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Common
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Common (
+
+    module System.Posix.DynamicLinker.Prim,
+    dlsym,
+    dlerror,
+    dlclose,
+    undl,
+    throwDLErrorIf,
+    Module(..)
+    )
+
+--  Usage:
+--  ******
+--  
+--  Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+--  offering a function
+--    @char \* mogrify (char\*,int)@
+--  and invoke @str = mogrify("test",1)@:
+-- 
+--  
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+-- 
+--  withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+--     funptr <- dlsym mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" \$ \\ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+--  
+
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker.Prim
+import Foreign
+import Foreign.C
+
+dlclose :: DL -> IO ()
+dlclose (DLHandle h) = throwDLErrorIf_ "dlclose" (/= 0) $ c_dlclose h
+dlclose h = error $ "dlclose: invalid argument" ++ (show h)
+
+dlerror :: IO String
+dlerror = c_dlerror >>= peekCString 
+
+-- |'dlsym' returns the address binding of the symbol described in @symbol@,
+-- as it occurs in the shared object identified by @source@.
+
+dlsym :: DL -> String -> IO (FunPtr a)
+dlsym source symbol = do
+  withCAString symbol $ \ s -> do
+    throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s
+
+-- |'undl' obtains the raw handle. You mustn't do something like
+-- @withDL mod flags $ liftM undl >>= \ p -> use p@
+
+undl :: DL -> Ptr ()
+undl = packDL
+
+throwDLErrorIf :: String -> (a -> Bool) -> IO a -> IO a
+throwDLErrorIf s p f = do
+  r <- f
+  if (p r)
+    then dlerror >>= \ err -> ioError (userError ( s ++ ": " ++ err))
+    else return r
+
+throwDLErrorIf_ :: String -> (a -> Bool) -> IO a -> IO ()
+throwDLErrorIf_ s p f = throwDLErrorIf s p f >> return ()
+
+-- abstract handle for dynamically loaded module (EXPORTED)
+--
+newtype Module = Module (Ptr ())
index c678fed..2e5d6fe 100644 (file)
@@ -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 (file)
index 0000000..59f45e2
--- /dev/null
@@ -0,0 +1,77 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Module.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- DLOpen support, old API
+--  Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs
+--  I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Module.ByteString (
+
+--  Usage:
+--  ******
+--  
+--  Let's assume you want to open a local shared library 'foo' (./libfoo.so)
+--  offering a function
+--    char * mogrify (char*,int)
+--  and invoke str = mogrify("test",1):
+-- 
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+-- 
+--  withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do
+--     funptr <- moduleSymbol mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" $ \ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+
+      Module
+    , moduleOpen             -- :: String -> ModuleFlags -> IO Module
+    , moduleSymbol           -- :: Source -> String -> IO (FunPtr a)
+    , moduleClose            -- :: Module -> IO Bool
+    , moduleError            -- :: IO String
+    , withModule             -- :: Maybe String 
+                             -- -> String 
+                            -- -> [ModuleFlags ]
+                            -- -> (Module -> IO a) 
+                            -- -> IO a
+    , withModule_            -- :: Maybe String 
+                            -- -> String 
+                            -- -> [ModuleFlags] 
+                            -- -> (Module -> IO a) 
+                            -- -> IO ()
+    )
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker.Module hiding (moduleOpen)
+import System.Posix.DynamicLinker.Prim
+import System.Posix.DynamicLinker.Common
+
+import Foreign
+import System.Posix.ByteString.FilePath
+
+-- Opens a module (EXPORTED)
+--
+
+moduleOpen :: RawFilePath -> [RTLDFlags] -> IO Module
+moduleOpen file flags = do
+  modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags)
+  if (modPtr == nullPtr)
+      then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err))
+      else return $ Module modPtr
index 2e5409e..9a21d77 100644 (file)
@@ -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 (file)
index 0000000..70b3f73
--- /dev/null
@@ -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@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 ()
index 5606388..5916d1a 100644 (file)
@@ -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@. 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@.
-setFdMode :: Fd -> FileMode -> IO ()
-setFdMode (Fd fd) m =
-  throwErrnoIfMinus1_ "setFdMode" (c_fchmod fd m)
-
-foreign import ccall unsafe "fchmod" 
-  c_fchmod :: CInt -> CMode -> IO CInt
-
--- | @setFileCreationMask mode@ sets the file mode creation mask to @mode@.
--- Modes set by this operation are subtracted from files and directories upon
--- creation. The previous file creation mask is returned.
---
--- Note: calls @umask@.
-setFileCreationMask :: FileMode -> IO FileMode
-setFileCreationMask mask = c_umask mask
-
 -- -----------------------------------------------------------------------------
 -- 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@.
-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@.
@@ -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@.
---
--- Note: calls @fstat@.
-getFdStatus :: Fd -> IO FileStatus
-getFdStatus (Fd fd) = do
-  fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) 
-  withForeignPtr fp $ \p ->
-    throwErrnoIfMinus1_ "getFdStatus" (c_fstat fd p)
-  return (FileStatus fp)
-
 -- | 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@. 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@.
-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@.
-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@.
 -- 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@. For defined file limits, @getFdPathVar@
--- returns the associated value.  For defined file options, the result of
--- @getFdPathVar@ is undefined, but not failure.
---
--- Note: calls @fpathconf@.
-getFdPathVar :: Fd -> PathVar -> IO Limit
-getFdPathVar (Fd fd) v =
-    throwErrnoIfMinus1 "getFdPathVar" $ 
-      c_fpathconf fd (pathVarConst v)
-
-foreign import ccall unsafe "fpathconf" 
-  c_fpathconf :: CInt -> CInt -> IO CLong
diff --git a/System/Posix/Files/ByteString.hsc b/System/Posix/Files/ByteString.hsc
new file mode 100644 (file)
index 0000000..5853ab9
--- /dev/null
@@ -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@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@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@
+-- doesn't exist or if the effective user ID of the current process is not that
+-- of the file's owner.
+--
+-- Note: calls @chmod@.
+setFileMode :: RawFilePath -> FileMode -> IO ()
+setFileMode name m =
+  withFilePath name $ \s -> do
+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+
+-- -----------------------------------------------------------------------------
+-- access()
+
+-- | @fileAccess name read write exec@ checks if the file (or other file system
+-- object) @name@ can be accessed for reading, writing and\/or executing. To
+-- check a permission set the corresponding argument to 'True'.
+--
+-- Note: calls @access@.
+fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool
+fileAccess name readOK writeOK execOK = access name flags
+  where
+   flags   = read_f .|. write_f .|. exec_f
+   read_f  = if readOK  then (#const R_OK) else 0
+   write_f = if writeOK then (#const W_OK) else 0
+   exec_f  = if execOK  then (#const X_OK) else 0
+
+-- | Checks for the existence of the file.
+--
+-- Note: calls @access@.
+fileExist :: RawFilePath -> IO Bool
+fileExist name = 
+  withFilePath name $ \s -> do
+    r <- c_access s (#const F_OK)
+    if (r == 0)
+       then return True
+       else do err <- getErrno
+               if (err == eNOENT)
+                  then return False
+                  else throwErrnoPath "fileExist" name
+
+access :: RawFilePath -> CMode -> IO Bool
+access name flags = 
+  withFilePath name $ \s -> do
+    r <- c_access s (fromIntegral flags)
+    if (r == 0)
+       then return True
+       else do err <- getErrno
+               if (err == eACCES)
+                  then return False
+                  else throwErrnoPath "fileAccess" name
+
+
+-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID,
+-- size, access times, etc.) for the file @path@.
+--
+-- Note: calls @stat@.
+getFileStatus :: RawFilePath -> IO FileStatus
+getFileStatus path = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) 
+  withForeignPtr fp $ \p ->
+    withFilePath path $ \s -> 
+      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@.
+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@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@
+-- already exists or if the effective user ID of the current process doesn't
+-- have permission to create the pipe.
+--
+-- Note: calls @mkfifo@.
+createNamedPipe :: RawFilePath -> FileMode -> IO ()
+createNamedPipe name mode = do
+  withFilePath name $ \s -> 
+    throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode)
+
+-- | @createDevice path mode dev@ creates either a regular or a special file
+-- depending on the value of @mode@ (and @dev@).  @mode@ will normally be either
+-- 'blockSpecialMode' or 'characterSpecialMode'.  May fail with
+-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the
+-- effective user ID of the current process doesn't have permission to create
+-- the file.
+--
+-- Note: calls @mknod@.
+createDevice :: RawFilePath -> FileMode -> DeviceID -> IO ()
+createDevice path mode dev =
+  withFilePath path $ \s ->
+    throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev)
+
+foreign import 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@.
+--
+-- Note: calls @link@.
+createLink :: RawFilePath -> RawFilePath -> IO ()
+createLink name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
+
+-- | @removeLink path@ removes the link named @path@.
+--
+-- Note: calls @unlink@.
+removeLink :: RawFilePath -> IO ()
+removeLink name =
+  withFilePath name $ \s ->
+  throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s)
+
+-- -----------------------------------------------------------------------------
+-- Symbolic Links
+
+-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@
+-- which points to the file @file1@.
+--
+-- Symbolic links are interpreted at run-time as if the contents of the link
+-- had been substituted into the path being followed to find a file or directory.
+--
+-- Note: calls @symlink@.
+createSymbolicLink :: RawFilePath -> RawFilePath -> IO ()
+createSymbolicLink file1 file2 =
+  withFilePath file1 $ \s1 ->
+  withFilePath file2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createSymbolicLink" 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@.
+readSymbolicLink :: RawFilePath -> IO RawFilePath
+readSymbolicLink file =
+  allocaArray0 (#const PATH_MAX) $ \buf -> do
+    withFilePath file $ \s -> do
+      len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ 
+       c_readlink s buf (#const PATH_MAX)
+      peekFilePathLen (buf,fromIntegral len)
+
+foreign import ccall unsafe "readlink"
+  c_readlink :: CString -> CString -> CSize -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Renaming files
+
+-- | @rename old new@ renames a file or directory from @old@ to @new@.
+--
+-- Note: calls @rename@.
+rename :: RawFilePath -> RawFilePath -> IO ()
+rename name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
+
+foreign import ccall unsafe "rename"
+   c_rename :: CString -> CString -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- chown()
+
+-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to
+-- @uid@ and @gid@, respectively.
+--
+-- If @uid@ or @gid@ is specified as -1, then that ID is not changed.
+--
+-- Note: calls @chown@.
+setOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO ()
+setOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid)
+
+foreign import ccall unsafe "chown"
+  c_chown :: CString -> CUid -> CGid -> IO CInt
+
+#if HAVE_LCHOWN
+-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus
+-- changes permissions on the link itself).
+--
+-- Note: calls @lchown@.
+setSymbolicLinkOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO ()
+setSymbolicLinkOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name
+       (c_lchown s uid gid)
+
+foreign import ccall unsafe "lchown"
+  c_lchown :: CString -> CUid -> CGid -> IO CInt
+#endif
+
+-- -----------------------------------------------------------------------------
+-- utime()
+
+-- | @setFileTimes path atime mtime@ sets the access and modification times
+-- associated with file @path@ to @atime@ and @mtime@, respectively.
+--
+-- Note: calls @utime@.
+setFileTimes :: RawFilePath -> EpochTime -> EpochTime -> IO ()
+setFileTimes name atime mtime = do
+  withFilePath name $ \s ->
+   allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do
+     (#poke struct utimbuf, actime)  p atime
+     (#poke struct utimbuf, modtime) p mtime
+     throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p)
+
+-- | @touchFile path@ sets the access and modification times associated with
+-- file @path@ to the current time.
+--
+-- Note: calls @utime@.
+touchFile :: RawFilePath -> IO ()
+touchFile name = do
+  withFilePath name $ \s ->
+   throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr)
+
+-- -----------------------------------------------------------------------------
+-- Setting file sizes
+
+-- | Truncates the file down to the specified length. If the file was larger
+-- than the given length before this operation was performed the extra is lost.
+--
+-- Note: calls @truncate@.
+setFileSize :: RawFilePath -> FileOffset -> IO ()
+setFileSize file off = 
+  withFilePath file $ \s ->
+    throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off)
+
+foreign import 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@.
+-- For defined file limits, @getPathVar@ returns the associated
+-- value.  For defined file options, the result of @getPathVar@
+-- is undefined, but not failure.
+--
+-- Note: calls @pathconf@.
+getPathVar :: RawFilePath -> PathVar -> IO Limit
+getPathVar name v = do
+  withFilePath name $ \ nameP -> 
+    throwErrnoPathIfMinus1 "getPathVar" name $ 
+      c_pathconf nameP (pathVarConst v)
+
+foreign import ccall unsafe "pathconf" 
+  c_pathconf :: CString -> CInt -> IO CLong
diff --git a/System/Posix/Files/Common.hsc b/System/Posix/Files/Common.hsc
new file mode 100644 (file)
index 0000000..2894244
--- /dev/null
@@ -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@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@.
+setFdMode :: Fd -> FileMode -> IO ()
+setFdMode (Fd fd) m =
+  throwErrnoIfMinus1_ "setFdMode" (c_fchmod fd m)
+
+foreign import ccall unsafe "fchmod" 
+  c_fchmod :: CInt -> CMode -> IO CInt
+
+-- | @setFileCreationMask mode@ sets the file mode creation mask to @mode@.
+-- Modes set by this operation are subtracted from files and directories upon
+-- creation. The previous file creation mask is returned.
+--
+-- Note: calls @umask@.
+setFileCreationMask :: FileMode -> IO FileMode
+setFileCreationMask mask = c_umask mask
+
+-- -----------------------------------------------------------------------------
+-- stat() support
+
+-- | POSIX defines operations to get information, such as owner, permissions,
+-- size and access times, about a file. This information is represented by the
+-- 'FileStatus' type.
+--
+-- Note: see @chmod@.
+newtype FileStatus = FileStatus (ForeignPtr CStat)
+
+-- | ID of the device on which this file resides.
+deviceID         :: FileStatus -> DeviceID
+-- | inode number
+fileID           :: FileStatus -> FileID
+-- | File mode (such as permissions).
+fileMode         :: FileStatus -> FileMode
+-- | Number of hard links to this file.
+linkCount        :: FileStatus -> LinkCount
+-- | ID of owner.
+fileOwner        :: FileStatus -> UserID
+-- | ID of group.
+fileGroup        :: FileStatus -> GroupID
+-- | Describes the device that this file represents.
+specialDeviceID  :: FileStatus -> DeviceID
+-- | Size of the file in bytes. If this file is a symbolic link the size is
+-- the length of the pathname it contains.
+fileSize         :: FileStatus -> FileOffset
+-- | Time of last access.
+accessTime       :: FileStatus -> EpochTime
+-- | Time of last 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@.
+--
+-- Note: calls @fstat@.
+getFdStatus :: Fd -> IO FileStatus
+getFdStatus (Fd fd) = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) 
+  withForeignPtr fp $ \p ->
+    throwErrnoIfMinus1_ "getFdStatus" (c_fstat fd p)
+  return (FileStatus fp)
+
+-- -----------------------------------------------------------------------------
+-- fchown()
+
+-- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a
+-- 'FilePath'.
+--
+-- Note: calls @fchown@.
+setFdOwnerAndGroup :: Fd -> UserID -> GroupID -> IO ()
+setFdOwnerAndGroup (Fd fd) uid gid = 
+  throwErrnoIfMinus1_ "setFdOwnerAndGroup" (c_fchown fd uid gid)
+
+foreign import ccall unsafe "fchown"
+  c_fchown :: CInt -> CUid -> CGid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- ftruncate()
+
+-- | Acts as 'setFileSize' but uses a file descriptor instead of a 'FilePath'.
+--
+-- Note: calls @ftruncate@.
+setFdSize :: Fd -> FileOffset -> IO ()
+setFdSize (Fd fd) off =
+  throwErrnoIfMinus1_ "setFdSize" (c_ftruncate fd off)
+
+-- -----------------------------------------------------------------------------
+-- pathconf()/fpathconf() support
+
+data PathVar
+  = FileSizeBits                 {- _PC_FILESIZEBITS     -}
+  | LinkLimit                     {- _PC_LINK_MAX         -}
+  | InputLineLimit                {- _PC_MAX_CANON        -}
+  | InputQueueLimit               {- _PC_MAX_INPUT        -}
+  | FileNameLimit                 {- _PC_NAME_MAX         -}
+  | PathNameLimit                 {- _PC_PATH_MAX         -}
+  | PipeBufferLimit               {- _PC_PIPE_BUF         -}
+                                 -- These are described as optional in POSIX:
+                                 {- _PC_ALLOC_SIZE_MIN     -}
+                                 {- _PC_REC_INCR_XFER_SIZE -}
+                                 {- _PC_REC_MAX_XFER_SIZE  -}
+                                 {- _PC_REC_MIN_XFER_SIZE  -}
+                                 {- _PC_REC_XFER_ALIGN     -}
+  | SymbolicLinkLimit            {- _PC_SYMLINK_MAX      -}
+  | SetOwnerAndGroupIsRestricted  {- _PC_CHOWN_RESTRICTED -}
+  | FileNamesAreNotTruncated      {- _PC_NO_TRUNC         -}
+  | VDisableChar                 {- _PC_VDISABLE         -}
+  | AsyncIOAvailable             {- _PC_ASYNC_IO         -}
+  | PrioIOAvailable              {- _PC_PRIO_IO          -}
+  | SyncIOAvailable              {- _PC_SYNC_IO          -}
+
+pathVarConst :: PathVar -> CInt
+pathVarConst v = case v of
+       LinkLimit                       -> (#const _PC_LINK_MAX)
+       InputLineLimit                  -> (#const _PC_MAX_CANON)
+       InputQueueLimit                 -> (#const _PC_MAX_INPUT)
+       FileNameLimit                   -> (#const _PC_NAME_MAX)
+       PathNameLimit                   -> (#const _PC_PATH_MAX)
+       PipeBufferLimit                 -> (#const _PC_PIPE_BUF)
+       SetOwnerAndGroupIsRestricted    -> (#const _PC_CHOWN_RESTRICTED)
+       FileNamesAreNotTruncated        -> (#const _PC_NO_TRUNC)
+       VDisableChar                    -> (#const _PC_VDISABLE)
+
+#ifdef _PC_SYNC_IO
+       SyncIOAvailable         -> (#const _PC_SYNC_IO)
+#else
+       SyncIOAvailable         -> error "_PC_SYNC_IO not available"
+#endif
+
+#ifdef _PC_ASYNC_IO
+       AsyncIOAvailable        -> (#const _PC_ASYNC_IO)
+#else
+       AsyncIOAvailable        -> error "_PC_ASYNC_IO not available"
+#endif
+
+#ifdef _PC_PRIO_IO
+       PrioIOAvailable         -> (#const _PC_PRIO_IO)
+#else
+       PrioIOAvailable         -> error "_PC_PRIO_IO not available"
+#endif
+
+#if _PC_FILESIZEBITS
+       FileSizeBits            -> (#const _PC_FILESIZEBITS)
+#else
+       FileSizeBits            -> error "_PC_FILESIZEBITS not available"
+#endif
+
+#if _PC_SYMLINK_MAX
+       SymbolicLinkLimit       -> (#const _PC_SYMLINK_MAX)
+#else
+       SymbolicLinkLimit       -> error "_PC_SYMLINK_MAX not available"
+#endif
+
+-- | @getFdPathVar var fd@ obtains the dynamic value of the requested
+-- configurable file limit or option associated with the file or directory
+-- attached to the open channel @fd@. For defined file limits, @getFdPathVar@
+-- returns the associated value.  For defined file options, the result of
+-- @getFdPathVar@ is undefined, but not failure.
+--
+-- Note: calls @fpathconf@.
+getFdPathVar :: Fd -> PathVar -> IO Limit
+getFdPathVar (Fd fd) v =
+    throwErrnoIfMinus1 "getFdPathVar" $ 
+      c_fpathconf fd (pathVarConst v)
+
+foreign import ccall unsafe "fpathconf" 
+  c_fpathconf :: CInt -> CInt -> IO CLong
index c1a2d0c..c5b8e55 100644 (file)
@@ -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_@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 (file)
index 0000000..518a2ec
--- /dev/null
@@ -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@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 (file)
index 0000000..e4a7671
--- /dev/null
@@ -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@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_@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
index 57779ce..9b1d72f 100644 (file)
@@ -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@.
-getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID
-getProcessGroupIDOf pid =
-  throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid)
-
-foreign import ccall unsafe "getpgid"
-  c_getpgid :: CPid -> IO CPid
-
-{-
-   To be added in the future, after the deprecation period for the
-   existing createProcessGroup has elapsed:
-
--- | 'createProcessGroup' calls @setpgid(0,0)@ to make
---   the current process a new process group leader.
-createProcessGroup :: IO ProcessGroupID
-createProcessGroup = do
-  throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0)
-  pgid <- getProcessGroupID
-  return pgid
--}
-
--- | @'createProcessGroupFor' pid@ calls @setpgid@ to make
---   process @pid@ a new process group leader.
-createProcessGroupFor :: ProcessID -> IO ProcessGroupID
-createProcessGroupFor pid = do
-  throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0)
-  return pid
-
--- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the
---   'ProcessGroupID' of the current process to @pgid@.
-joinProcessGroup :: ProcessGroupID -> IO ()
-joinProcessGroup pgid =
-  throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
-
-{-
-   To be added in the future, after the deprecation period for the
-   existing setProcessGroupID has elapsed:
-
--- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the
---   'ProcessGroupID' of the current process to @pgid@.
-setProcessGroupID :: ProcessGroupID -> IO ()
-setProcessGroupID pgid =
-  throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid)
--}
-
--- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the
---   'ProcessGroupIDOf' for process @pid@ to @pgid@.
-setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO ()
-setProcessGroupIDOf pid pgid =
-  throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid)
-
-foreign import ccall unsafe "setpgid"
-  c_setpgid :: CPid -> CPid -> IO CInt
-
--- | 'createSession' calls @setsid@ to create a new session
---   with the current process as session leader.
-createSession :: IO ProcessGroupID
-createSession = throwErrnoIfMinus1 "createSession" c_setsid
-
-foreign import ccall unsafe "setsid"
-  c_setsid :: IO CPid
-
--- -----------------------------------------------------------------------------
--- Process times
-
--- All times in clock ticks (see getClockTick)
-
-data ProcessTimes
-  = ProcessTimes { elapsedTime     :: ClockTick
-                , userTime        :: ClockTick
-                , systemTime      :: ClockTick
-                , childUserTime   :: ClockTick
-                , childSystemTime :: ClockTick
-                }
-
--- | 'getProcessTimes' calls @times@ to obtain time-accounting
---   information for the current process and its children.
-getProcessTimes :: IO ProcessTimes
-getProcessTimes = do
-   allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do
-     elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
-     ut  <- (#peek struct tms, tms_utime)  p_tms
-     st  <- (#peek struct tms, tms_stime)  p_tms
-     cut <- (#peek struct tms, tms_cutime) p_tms
-     cst <- (#peek struct tms, tms_cstime) p_tms
-     return (ProcessTimes{ elapsedTime     = elapsed,
-                          userTime        = ut,
-                          systemTime      = st,
-                          childUserTime   = cut,
-                          childSystemTime = cst
-                         })
-
-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@.
---   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@.
---   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 (file)
index 0000000..e7b902e
--- /dev/null
@@ -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@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 (file)
index 0000000..1e7299f
--- /dev/null
@@ -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@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@.
+getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID
+getProcessGroupIDOf pid =
+  throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid)
+
+foreign import ccall unsafe "getpgid"
+  c_getpgid :: CPid -> IO CPid
+
+{-
+   To be added in the future, after the deprecation period for the
+   existing createProcessGroup has elapsed:
+
+-- | 'createProcessGroup' calls @setpgid(0,0)@ to make
+--   the current process a new process group leader.
+createProcessGroup :: IO ProcessGroupID
+createProcessGroup = do
+  throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0)
+  pgid <- getProcessGroupID
+  return pgid
+-}
+
+-- | @'createProcessGroupFor' pid@ calls @setpgid@ to make
+--   process @pid@ a new process group leader.
+createProcessGroupFor :: ProcessID -> IO ProcessGroupID
+createProcessGroupFor pid = do
+  throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0)
+  return pid
+
+-- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the
+--   'ProcessGroupID' of the current process to @pgid@.
+joinProcessGroup :: ProcessGroupID -> IO ()
+joinProcessGroup pgid =
+  throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
+
+{-
+   To be added in the future, after the deprecation period for the
+   existing setProcessGroupID has elapsed:
+
+-- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the
+--   'ProcessGroupID' of the current process to @pgid@.
+setProcessGroupID :: ProcessGroupID -> IO ()
+setProcessGroupID pgid =
+  throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid)
+-}
+
+-- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the
+--   'ProcessGroupIDOf' for process @pid@ to @pgid@.
+setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO ()
+setProcessGroupIDOf pid pgid =
+  throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid)
+
+foreign import ccall unsafe "setpgid"
+  c_setpgid :: CPid -> CPid -> IO CInt
+
+-- | 'createSession' calls @setsid@ to create a new session
+--   with the current process as session leader.
+createSession :: IO ProcessGroupID
+createSession = throwErrnoIfMinus1 "createSession" c_setsid
+
+foreign import ccall unsafe "setsid"
+  c_setsid :: IO CPid
+
+-- -----------------------------------------------------------------------------
+-- Process times
+
+-- All times in clock ticks (see getClockTick)
+
+data ProcessTimes
+  = ProcessTimes { elapsedTime     :: ClockTick
+                , userTime        :: ClockTick
+                , systemTime      :: ClockTick
+                , childUserTime   :: ClockTick
+                , childSystemTime :: ClockTick
+                }
+
+-- | 'getProcessTimes' calls @times@ to obtain time-accounting
+--   information for the current process and its children.
+getProcessTimes :: IO ProcessTimes
+getProcessTimes = do
+   allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do
+     elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
+     ut  <- (#peek struct tms, tms_utime)  p_tms
+     st  <- (#peek struct tms, tms_stime)  p_tms
+     cut <- (#peek struct tms, tms_cutime) p_tms
+     cst <- (#peek struct tms, tms_cstime) p_tms
+     return (ProcessTimes{ elapsedTime     = elapsed,
+                          userTime        = ut,
+                          systemTime      = st,
+                          childUserTime   = cut,
+                          childSystemTime = cst
+                         })
+
+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@.
+--   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@.
+--   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 (file)
index 0000000..c5f8906
--- /dev/null
@@ -0,0 +1,82 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Temp.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org>
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@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
+
index c861a3f..0a2866a 100644 (file)
@@ -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@.
-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@.
-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@.
-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@.
-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@.
-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@.
-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@.
-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@. 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 (file)
index 0000000..b3ca9a9
--- /dev/null
@@ -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@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@. 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 (file)
index 0000000..39a2e30
--- /dev/null
@@ -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@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@.
+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@.
+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@.
+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@.
+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@.
+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@.
+getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
+getTerminalProcessGroupID (Fd fd) = do
+  throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
+
+foreign import ccall unsafe "tcgetpgrp"
+  c_tcgetpgrp :: CInt -> IO CPid
+
+-- | @setTerminalProcessGroupID fd pgid@ calls @tcsetpgrp@ to
+--   set the @ProcessGroupID@ of the foreground process group 
+--   associated with the terminal attached to @Fd@ 
+--   @fd@ to @pgid@.
+setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
+setTerminalProcessGroupID (Fd fd) pgid =
+  throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid)
+
+foreign import ccall unsafe "tcsetpgrp"
+  c_tcsetpgrp :: CInt -> CPid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- file descriptor queries
+
+-- | @queryTerminal fd@ calls @isatty@ to determine whether or
+--   not @Fd@ @fd@ is associated with a terminal.
+queryTerminal :: Fd -> IO Bool
+queryTerminal (Fd fd) = do
+  r <- c_isatty fd
+  return (r == 1)
+  -- ToDo: the spec says that it can set errno to EBADF if the result is zero
+
+foreign import ccall unsafe "isatty"
+  c_isatty :: CInt -> IO CInt
+
+-- | @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
index 4b888be..8f8a152 100644 (file)
@@ -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'])
index a393d72..e1d1661 100644 (file)
@@ -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/fileStatusByteString.hs b/tests/fileStatusByteString.hs
new file mode 100644 (file)
index 0000000..35d52d8
--- /dev/null
@@ -0,0 +1,105 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- GHC trac #2969
+
+import System.Posix.ByteString
+import Control.Exception as E
+import Control.Monad
+
+main = do
+  cleanup
+  fs <- testRegular
+  ds <- testDir
+  testSymlink fs ds
+  cleanup
+
+regular      = "regular2"
+dir          = "dir2"
+link_regular = "link-regular2"
+link_dir     = "link-dir2"
+
+testRegular = do
+  createFile regular ownerReadMode
+  (fs, _) <- getStatus regular
+  let expected = (False,False,False,True,False,False,False)
+      actual   = snd (statusElements fs)
+  when (actual /= expected) $
+    fail "unexpected file status bits for regular file"
+  return fs
+
+testDir = do
+  createDirectory dir ownerReadMode
+  (ds, _) <- getStatus dir
+  let expected = (False,False,False,False,True,False,False)
+      actual   = snd (statusElements ds)
+  when (actual /= expected) $
+    fail "unexpected file status bits for directory"
+  return ds
+
+testSymlink fs ds = do
+  createSymbolicLink regular link_regular
+  createSymbolicLink dir     link_dir
+  (fs', ls)  <- getStatus link_regular
+  (ds', lds) <- getStatus link_dir
+
+  let expected = (False,False,False,False,False,True,False)
+      actualF  = snd (statusElements ls)
+      actualD  = snd (statusElements lds)
+
+  when (actualF /= expected) $
+    fail "unexpected file status bits for symlink to regular file"
+
+  when (actualD /= expected) $
+    fail "unexpected file status bits for symlink to directory"
+
+  when (statusElements fs /= statusElements fs') $
+    fail "status for a file does not match when it's accessed via a symlink"
+
+  when (statusElements ds /= statusElements ds') $
+    fail "status for a directory does not match when it's accessed via a symlink"
+
+cleanup = do
+  ignoreIOExceptions $ removeDirectory dir
+  mapM_ (ignoreIOExceptions . removeLink)
+        [regular, link_regular, link_dir]
+
+ignoreIOExceptions io = io `E.catch`
+                        ((\_ -> return ()) :: IOException -> IO ())
+
+getStatus f = do
+  fs  <- getFileStatus f
+  ls  <- getSymbolicLinkStatus f
+
+  fd  <- openFd f ReadOnly Nothing defaultFileFlags
+  fs' <- getFdStatus fd
+
+  when (statusElements fs /= statusElements fs') $
+    fail "getFileStatus and getFdStatus give inconsistent results"
+
+  when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $
+    fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results "
+        ++ "on a file that is not a symbolic link"
+
+  return (fs, ls)
+
+-- Yay for 17-element tuples!
+statusElements fs = (,)
+  (deviceID fs
+  ,fileMode fs
+  ,linkCount fs
+  ,fileOwner fs
+  ,fileGroup fs
+  ,specialDeviceID fs
+  ,fileSize fs
+  ,accessTime fs
+  ,modificationTime fs
+  ,statusChangeTime fs
+  )
+  (isBlockDevice fs
+  ,isCharacterDevice fs
+  ,isNamedPipe fs
+  ,isRegularFile fs
+  ,isDirectory fs
+  ,isSymbolicLink fs
+  ,isSocket fs
+  )
diff --git a/tests/getEnvironment02.hs b/tests/getEnvironment02.hs
new file mode 100644 (file)
index 0000000..be920df
--- /dev/null
@@ -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 (file)
index 0000000..0ca9514
--- /dev/null
@@ -0,0 +1 @@
+True
index a6f95e4..d07f043 100644 (file)
@@ -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