unix 2.5.0.0 → 2.5.1.0

raw patch · 40 files changed

+3886/−1804 lines, 40 filesdep +bytestringdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• System/Posix.hs +10/−1
• System/Posix/ByteString.hs +69/−0
• System/Posix/ByteString/FilePath.hsc +123/−0
• System/Posix/Directory.hsc +9/−53
• System/Posix/Directory/ByteString.hsc +155/−0
• System/Posix/Directory/Common.hsc +80/−0
• System/Posix/DynamicLinker.hsc +8/−35
• System/Posix/DynamicLinker/ByteString.hsc +70/−0
• System/Posix/DynamicLinker/Common.hsc +90/−0
• System/Posix/DynamicLinker/Module.hsc +5/−5
• System/Posix/DynamicLinker/Module/ByteString.hsc +77/−0
• System/Posix/DynamicLinker/Prim.hsc +5/−2
• System/Posix/Env.hsc +4/−1
• System/Posix/Env/ByteString.hsc +165/−0
• System/Posix/Error.hs +7/−2
• System/Posix/Files.hsc +12/−328
• System/Posix/Files/ByteString.hsc +382/−0
• System/Posix/Files/Common.hsc +408/−0
• System/Posix/IO.hsc +10/−393
• System/Posix/IO/ByteString.hsc +102/−0
• System/Posix/IO/Common.hsc +456/−0
• System/Posix/Process.hsc +6/−331
• System/Posix/Process/ByteString.hsc +140/−0
• System/Posix/Process/Common.hsc +401/−0
• System/Posix/Process/Internals.hs +3/−0
• System/Posix/Resource.hsc +3/−0
• System/Posix/Semaphore.hsc +3/−1
• System/Posix/SharedMem.hsc +3/−1
• System/Posix/Signals.hsc +6/−3
• System/Posix/Signals/Exts.hsc +4/−1
• System/Posix/Temp.hsc +3/−0
• System/Posix/Temp/ByteString.hsc +82/−0
• System/Posix/Terminal.hsc +30/−631
• System/Posix/Terminal/ByteString.hsc +194/−0
• System/Posix/Terminal/Common.hsc +705/−0
• System/Posix/Time.hsc +3/−0
• System/Posix/Unistd.hsc +3/−0
• System/Posix/User.hsc +3/−0
• cbits/HsUnix.c +3/−3
• unix.cabal +44/−13

@@ -1,3 +1,6 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix@@ -27,7 +30,10 @@   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@@ -45,6 +51,9 @@ 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 

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

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

@@ -1,8 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}+#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) -- @@ -10,7 +14,7 @@ -- Stability   :  provisional -- Portability :  non-portable (requires POSIX) ----- POSIX directory support+-- String-based POSIX directory support -- ----------------------------------------------------------------------------- @@ -39,6 +43,9 @@ 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@@ -67,8 +74,6 @@ 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@@ -106,9 +111,6 @@ 		    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@@ -119,46 +121,7 @@ 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. getWorkingDirectory :: IO FilePath@@ -203,10 +166,3 @@  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

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

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

@@ -1,3 +1,6 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.DynamicLinker@@ -45,13 +48,14 @@  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@@ -64,39 +68,8 @@   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 ()

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

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

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.DynamicLinker.Module@@ -57,7 +60,8 @@ #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@@ -66,10 +70,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

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

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.DynamicLinker.Prim@@ -27,7 +30,7 @@   packRTLDFlags,   RTLDFlags(..),   packDL,-  DL(..)+  DL(..),  )  where@@ -36,7 +39,7 @@  import Data.Bits	( (.|.) ) import Foreign.Ptr	( Ptr, FunPtr, nullPtr )-import Foreign.C.Types	( CInt )+import Foreign.C.Types import Foreign.C.String	( CString )  -- RTLD_NEXT madness

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Env@@ -26,7 +29,7 @@ #include "HsUnix.h"  import Foreign.C.Error	( throwErrnoIfMinus1_ )-import Foreign.C.Types	( CInt )+import Foreign.C.Types import Foreign.C.String import Foreign.Marshal.Array import Foreign.Ptr

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

@@ -1,3 +1,6 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Error@@ -28,11 +31,13 @@ import Foreign import Foreign.C -throwErrnoPathIfMinus1Retry :: Num a => String -> FilePath -> IO a -> IO a+throwErrnoPathIfMinus1Retry :: (Eq a, Num a)+                            => String -> FilePath -> IO a -> IO a throwErrnoPathIfMinus1Retry loc path f =   throwErrnoPathIfRetry (== -1) loc path f -throwErrnoPathIfMinus1Retry_ :: Num a => String -> FilePath -> IO a -> IO ()+throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a)+                             => String -> FilePath -> IO a -> IO () throwErrnoPathIfMinus1Retry_ loc path f =   void $ throwErrnoPathIfRetry (== -1) loc path f 

@@ -1,5 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Files@@ -86,13 +89,15 @@     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@@ -115,114 +120,7 @@ #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@@@ -235,25 +133,6 @@   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() @@ -295,93 +174,7 @@ 		   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@. --@@ -394,16 +187,6 @@       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.@@ -417,10 +200,10 @@       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@@ -543,17 +326,6 @@ 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).@@ -608,81 +380,9 @@ 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@@ -698,19 +398,3 @@  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

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

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

@@ -1,6 +1,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -XRecordWildCards #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.IO@@ -18,6 +21,8 @@ -- ----------------------------------------------------------------------------- +#include "HsUnix.h"+ module System.Posix.IO (     -- * Input \/ Output @@ -63,36 +68,9 @@    ) 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 )@@ -101,81 +79,6 @@ 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@@ -183,32 +86,10 @@        -> 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@@ -217,267 +98,3 @@ 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

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

@@ -0,0 +1,456 @@+{-# 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 "HsUnix.h close"+   c_close :: CInt -> IO CInt++-- -----------------------------------------------------------------------------+-- Converting file descriptors to/from Handles++-- | Extracts the 'Fd' from a 'Handle'.  This function has the side effect+-- of closing the 'Handle' and flushing its write buffer, if necessary.+handleToFd :: Handle -> IO Fd++-- | Converts an 'Fd' into a 'Handle' that can be used with the+-- standard Haskell IO library (see "System.IO").  +--+-- 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" (Base.c_fcntl_read fd flag)+  return ((r .&. fdOption2Int opt) /= 0)+ where+  flag    = case opt of+	      CloseOnExec       -> (#const F_GETFD)+	      _    		-> (#const F_GETFL)++-- | May throw an exception if this is an invalid descriptor.+setFdOption :: Fd -> FdOption -> Bool -> IO ()+setFdOption (Fd fd) opt val = do+  r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag)+  let r' | val       = r .|. opt_val+	 | otherwise = r .&. (complement opt_val)+  throwErrnoIfMinus1_ "setFdOption"+                      (Base.c_fcntl_write fd setflag (fromIntegral r'))+ where+  (getflag,setflag)= case opt of+	      CloseOnExec       -> ((#const F_GETFD),(#const F_SETFD)) +	      _    		-> ((#const F_GETFL),(#const F_SETFL))+  opt_val = fdOption2Int opt++-- -----------------------------------------------------------------------------+-- Seeking ++mode2Int :: SeekMode -> CInt+mode2Int AbsoluteSeek = (#const SEEK_SET)+mode2Int RelativeSeek = (#const SEEK_CUR)+mode2Int SeekFromEnd  = (#const SEEK_END)++-- | May throw an exception if this is an invalid descriptor.+fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset+fdSeek (Fd fd) mode off =+  throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))++-- -----------------------------------------------------------------------------+-- Locking++data LockRequest = ReadLock+                 | WriteLock+                 | Unlock++type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)++-- | May throw an exception if this is an invalid descriptor.+getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))+getLock (Fd fd) lock =+  allocaLock lock $ \p_flock -> do+    throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock)+    result <- bytes2ProcessIDAndLock p_flock+    return (maybeResult result)+  where+    maybeResult (_, (Unlock, _, _, _)) = Nothing+    maybeResult x = Just x++type CFLock     = ()++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" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock)++-- | May throw an exception if this is an invalid descriptor.+waitToSetLock :: Fd -> FileLock -> IO ()+waitToSetLock (Fd fd) lock = do+  allocaLock lock $ \p_flock ->+    throwErrnoIfMinus1_ "waitToSetLock" +        (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock)++-- -----------------------------------------------------------------------------+-- fd{Read,Write}++-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding.+-- Throws an exception if this is an invalid descriptor, or EOF has been+-- reached.+fdRead :: Fd+       -> ByteCount -- ^How many bytes to read+       -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read.+fdRead _fd 0 = return ("", 0)+fdRead fd nbytes = do+    allocaBytes (fromIntegral nbytes) $ \ buf -> do+    rc <- fdReadBuf fd buf nbytes+    case rc of+      0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF")+      n -> do+       s <- peekCStringLen (castPtr buf, fromIntegral n)+       return (s, n)++-- | Read data from an 'Fd' into memory.  This is exactly equivalent+-- to the POSIX @read@ function.+fdReadBuf :: Fd+          -> Ptr Word8 -- ^ Memory in which to put the data+          -> ByteCount -- ^ Maximum number of bytes to read+          -> IO ByteCount -- ^ Number of bytes read (zero for EOF)+fdReadBuf _fd _buf 0 = return 0+fdReadBuf fd buf nbytes = +  fmap fromIntegral $+    throwErrnoIfMinus1Retry "fdReadBuf" $ +      c_safe_read (fromIntegral fd) (castPtr buf) nbytes++foreign import ccall safe "read"+   c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize++-- | Write a 'String' to an 'Fd' using the locale encoding.+fdWrite :: Fd -> String -> IO ByteCount+fdWrite fd str = +  withCStringLen str $ \ (buf,len) ->+    fdWriteBuf fd (castPtr buf) (fromIntegral len)++-- | Write data from memory to an 'Fd'.  This is exactly equivalent+-- to the POSIX @write@ function.+fdWriteBuf :: Fd+           -> Ptr Word8    -- ^ Memory containing the data to write+           -> ByteCount    -- ^ Maximum number of bytes to write+           -> IO ByteCount -- ^ Number of bytes written+fdWriteBuf fd buf len =+  fmap fromIntegral $+    throwErrnoIfMinus1Retry "fdWriteBuf" $ +      c_safe_write (fromIntegral fd) (castPtr buf) len++foreign import ccall safe "write" +   c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Process@@ -67,23 +70,10 @@  #include "HsUnix.h" -import Foreign.C.Error-import Foreign.C.String-import Foreign.C.Types ( CInt, CClock )-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 )@@ -96,216 +86,6 @@ {-# 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@@ -353,108 +133,3 @@ 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)---- -----------------------------------------------------------------------------

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

@@ -0,0 +1,401 @@+{-# 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.+-}++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)++-- -----------------------------------------------------------------------------

@@ -1,3 +1,6 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif  module System.Posix.Process.Internals (        pPrPr_disableITimers, c_execvpe,

@@ -1,5 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -w #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See

@@ -1,5 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}-+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Semaphore

@@ -1,6 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}-+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.SharedMem

@@ -1,5 +1,8 @@-{-# LANGUAGE DeriveDataTypeable,PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, PatternGuards, CApiFFI #-} {-# OPTIONS_GHC -fno-cse #-} -- global variables+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Signals@@ -296,7 +299,7 @@ raiseSignal :: Signal -> IO () raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig) -#if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS))+#if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)) || defined(netbsd_HOST_OS) foreign import ccall unsafe "genericRaise"   c_raise :: CInt -> IO CInt #else@@ -594,7 +597,7 @@   -- (-1) with errno set to EINTR.   -- XXX My manpage says it can also return EFAULT. And why is ignoring   -- EINTR the right thing to do?- + foreign import ccall unsafe "sigsuspend"   c_sigsuspend :: Ptr CSigset -> IO CInt #endif

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Signals.Exts@@ -27,7 +30,7 @@    ) where -import Foreign.C ( CInt )+import Foreign.C import System.Posix.Signals  #ifdef __HUGS__

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Temp

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

@@ -1,5 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Terminal@@ -70,439 +73,32 @@  #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 ( CInt )-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---- | @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+import System.Posix.IO --- | @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)+#if __GLASGOW_HASKELL__ > 700+import System.Posix.Internals (withFilePath, peekFilePath)+#elif __GLASGOW_HASKELL__ > 611+import System.Posix.Internals (withFilePath) -foreign import ccall unsafe "tcsetpgrp"-  c_tcsetpgrp :: CInt -> CPid -> IO CInt+peekFilePath :: CString -> IO FilePath+peekFilePath = peekCString --- -------------------------------------------------------------------------------- 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@@ -511,7 +107,7 @@ 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@@ -524,7 +120,7 @@ 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@@ -537,7 +133,7 @@ #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@@ -546,6 +142,10 @@     ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) #endif +-- -----------------------------------------------------------------------------+-- openPseudoTerminal needs to be here because it depends on+-- getSlaveTerminalName.+ -- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and -- returns the newly created pair as a (@master@, @slave@) tuple. openPseudoTerminal :: IO (Fd, Fd)@@ -603,204 +203,3 @@ #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

@@ -0,0 +1,194 @@+{-# 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 System.Posix.IO.ByteString+import Data.ByteString.Char8 as B++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++-- -----------------------------------------------------------------------------+-- openPseudoTerminal needs to be here because it depends on+-- getSlaveTerminalName.++-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and+-- returns the newly created pair as a (@master@, @slave@) tuple.+openPseudoTerminal :: IO (Fd, Fd)++#ifdef HAVE_OPENPTY+openPseudoTerminal =+  alloca $ \p_master ->+    alloca $ \p_slave -> do+      throwErrnoIfMinus1_ "openPty"+          (c_openpty p_master p_slave nullPtr nullPtr nullPtr)+      master <- peek p_master+      slave <- peek p_slave+      return (Fd master, Fd slave)++foreign import ccall unsafe "openpty"+  c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a+            -> IO CInt+#else+openPseudoTerminal = do+  (Fd master) <- openFd (B.pack "/dev/ptmx") ReadWrite Nothing+                        defaultFileFlags{noctty=True}+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master)+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master)+  slaveName <- getSlaveTerminalName (Fd master)+  slave <- openFd slaveName ReadWrite Nothing defaultFileFlags{noctty=True}+  pushModule slave "ptem"+  pushModule slave "ldterm"+# ifndef __hpux+  pushModule slave "ttcompat"+# endif /* __hpux */+  return (Fd master, slave)++-- Push a STREAMS module, for System V systems.+pushModule :: Fd -> String -> IO ()+pushModule (Fd fd) name =+  withCString name $ \p_name ->+    throwErrnoIfMinus1_ "openPseudoTerminal"+                        (c_push_module fd p_name)++foreign import ccall unsafe "__hsunix_push_module"+  c_push_module :: CInt -> CString -> IO CInt++#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 */

@@ -0,0 +1,705 @@+{-# 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,++  CTermios,+  TerminalMode(..),+  withoutMode,+  withMode,+  terminalMode,+  bitsPerByte,+  withBits,++  ControlCharacter(..),+  controlChar,+  withCC,+  withoutCC,++  inputTime,+  withTime,+  minInput,+  withMinInput,++  BaudRate(..),+  inputSpeed,+  withInputSpeed,+  outputSpeed,+  withOutputSpeed,++  -- ** Terminal operations+  sendBreak,+  drainOutput,+  QueueSelector(..),+  discardData,+  FlowAction(..),+  controlFlow,++  -- ** Process groups+  getTerminalProcessGroupID,+  setTerminalProcessGroupID,++  -- ** Testing a file descriptor+  queryTerminal,+  ) where++#include "HsUnix.h"++import Data.Bits+import Data.Char+import Foreign.C.Error ( 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++-- -----------------------------------------------------------------------------+-- 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

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Time

@@ -1,5 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-binds #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.Unistd

@@ -1,4 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Posix.User

@@ -24,10 +24,10 @@ #endif  #ifdef SIGINFO-int __hsunix_SIGINFO()	{ return SIGINFO; }+int __hsunix_SIGINFO(void)	{ return SIGINFO; } #endif #ifdef SIGWINCH-int __hsunix_SIGWINCH()	{ return SIGWINCH; }+int __hsunix_SIGWINCH(void)	{ return SIGWINCH; } #endif  // lstat is a macro on some platforms, so we need a wrapper:@@ -158,7 +158,7 @@  * (PATH_MAX is not defined on systems with unlimited path length,  * e.g. the Hurd).  */-HsInt __hsunix_long_path_size() {+HsInt __hsunix_long_path_size(void) { #ifdef PATH_MAX     return PATH_MAX; #else

@@ -1,5 +1,5 @@ name:		unix-version:	2.5.0.0+version:        2.5.1.0 license:	BSD3 license-file:	LICENSE maintainer:	libraries@haskell.org@@ -27,19 +27,10 @@ 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 @@         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.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.DynamicLinker.Common+        System.Posix.Files.Common+        System.Posix.IO.Common+        System.Posix.Process.Common+        System.Posix.Terminal.Common++    build-depends:      base >= 4.2 && < 4.6,+                        bytestring >= 0.9.2.0 && < 0.10     extensions: CPP, ForeignFunctionInterface, EmptyDataDecls     if impl(ghc >= 7.1)         extensions: NondecreasingIndentation