-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- #hide
module System.Posix.Internals where
-#ifndef __NHC__
+#ifdef __NHC__
+#define HTYPE_TCFLAG_T
+#else
# include "HsBaseConfig.h"
#endif
import Foreign
import Foreign.C
-import Data.Bits
+-- import Data.Bits
import Data.Maybe
#if !defined(HTYPE_TCFLAG_T)
import GHC.Base
import GHC.Num
import GHC.Real
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.IOMode
+import GHC.IO.Exception
+import GHC.IO.Device
+#ifndef mingw32_HOST_OS
+import {-# SOURCE #-} GHC.IO.Encoding (fileSystemEncoding)
+import qualified GHC.Foreign as GHC
+#endif
#elif __HUGS__
import Hugs.Prelude (IOException(..), IOErrorType(..))
import Hugs.IO (IOMode(..))
#elif __NHC__
+import GHC.IO.Device -- yes, I know, but its portable, really!
import System.IO
import Control.Exception
import DIOError
#endif
#ifdef __HUGS__
-{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
+{-# CFILES cbits/PrelIOUtils.c cbits/consUtils.c #-}
#endif
+
+-- ---------------------------------------------------------------------------
+-- Debugging the base package
+
+puts :: String -> IO ()
+puts s = withCAStringLen (s ++ "\n") $ \(p, len) -> do
+ -- In reality should be withCString, but assume ASCII to avoid loop
+ -- if this is called by GHC.Foreign
+ _ <- c_write 1 (castPtr p) (fromIntegral len)
+ return ()
+
+
-- ---------------------------------------------------------------------------
-- Types
-type CDir = ()
-type CDirent = ()
type CFLock = ()
type CGroup = ()
type CLconv = ()
type CUtimbuf = ()
type CUtsname = ()
-#ifndef __GLASGOW_HASKELL__
type FD = CInt
-#endif
-- ---------------------------------------------------------------------------
-- stat()-related stuff
fdFileSize :: FD -> IO Integer
fdFileSize fd =
allocaBytes sizeof_stat $ \ p_stat -> do
- throwErrnoIfMinus1Retry "fileSize" $
+ throwErrnoIfMinus1Retry_ "fileSize" $
c_fstat fd p_stat
c_mode <- st_mode p_stat :: IO CMode
if not (s_isreg c_mode)
c_size <- st_size p_stat
return (fromIntegral c_size)
-data FDType = Directory | Stream | RegularFile | RawDevice
- deriving (Eq)
-
-fileType :: FilePath -> IO FDType
+fileType :: FilePath -> IO IODeviceType
fileType file =
allocaBytes sizeof_stat $ \ p_stat -> do
- withCString file $ \p_file -> do
- throwErrnoIfMinus1Retry "fileType" $
+ withFilePath file $ \p_file -> do
+ throwErrnoIfMinus1Retry_ "fileType" $
c_stat p_file p_stat
statGetType p_stat
-- NOTE: On Win32 platforms, this will only work with file descriptors
-- referring to file handles. i.e., it'll fail for socket FDs.
-fdStat :: FD -> IO (FDType, CDev, CIno)
+fdStat :: FD -> IO (IODeviceType, CDev, CIno)
fdStat fd =
allocaBytes sizeof_stat $ \ p_stat -> do
- throwErrnoIfMinus1Retry "fdType" $
+ throwErrnoIfMinus1Retry_ "fdType" $
c_fstat fd p_stat
ty <- statGetType p_stat
dev <- st_dev p_stat
ino <- st_ino p_stat
return (ty,dev,ino)
-fdType :: FD -> IO FDType
+fdType :: FD -> IO IODeviceType
fdType fd = do (ty,_,_) <- fdStat fd; return ty
-statGetType :: Ptr CStat -> IO FDType
+statGetType :: Ptr CStat -> IO IODeviceType
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
ioe_unknownfiletype = UserError "fdType" "unknown file type"
#endif
-#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
-closeFd :: Bool -> CInt -> IO CInt
-closeFd isStream fd
- | isStream = c_closesocket fd
- | otherwise = c_close fd
-
-foreign import stdcall unsafe "HsBase.h closesocket"
- c_closesocket :: CInt -> IO CInt
-#endif
-
fdGetMode :: FD -> IO IOMode
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
fdGetMode _ = do
return mode
+#ifdef mingw32_HOST_OS
+withFilePath :: FilePath -> (CWString -> IO a) -> IO a
+withFilePath = withCWString
+
+peekFilePath :: CWString -> IO FilePath
+peekFilePath = peekCWString
+#else
+
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+peekFilePath :: CString -> IO FilePath
+peekFilePathLen :: CStringLen -> IO FilePath
+
+#if __GLASGOW_HASKELL__
+withFilePath = GHC.withCString fileSystemEncoding
+peekFilePath = GHC.peekCString fileSystemEncoding
+peekFilePathLen = GHC.peekCStringLen fileSystemEncoding
+#else
+withFilePath = withCString
+peekFilePath = peekCString
+peekFilePathLen = peekCStringLen
+#endif
+
+#endif
+
-- ---------------------------------------------------------------------------
-- Terminal-related stuff
-fdIsTTY :: FD -> IO Bool
-fdIsTTY fd = c_isatty fd >>= return.toBool
-
#if defined(HTYPE_TCFLAG_T)
setEcho :: FD -> Bool -> IO ()
tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr fd fun = do
allocaBytes sizeof_termios $ \p_tios -> do
- throwErrnoIfMinus1Retry "tcSetAttr"
+ throwErrnoIfMinus1Retry_ "tcSetAttr"
(c_tcgetattr fd p_tios)
#ifdef __GLASGOW_HASKELL__
-- wrapper which temporarily blocks SIGTTOU around the call, making it
-- transparent.
allocaBytes sizeof_sigset_t $ \ p_sigset -> do
- allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
- c_sigemptyset p_sigset
- c_sigaddset p_sigset const_sigttou
- c_sigprocmask const_sig_block p_sigset p_old_sigset
+ allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
+ throwErrnoIfMinus1_ "sigemptyset" $
+ c_sigemptyset p_sigset
+ throwErrnoIfMinus1_ "sigaddset" $
+ c_sigaddset p_sigset const_sigttou
+ throwErrnoIfMinus1_ "sigprocmask" $
+ c_sigprocmask const_sig_block p_sigset p_old_sigset
r <- fun p_tios -- do the business
throwErrnoIfMinus1Retry_ "tcSetAttr" $
c_tcsetattr fd const_tcsanow p_tios
- c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+ throwErrnoIfMinus1_ "sigprocmask" $
+ c_sigprocmask const_sig_setmask p_old_sigset nullPtr
return r
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "consUtils.h get_console_echo__"
get_console_echo :: CInt -> IO CInt
+foreign import ccall unsafe "consUtils.h is_console__"
+ is_console :: CInt -> IO CInt
+
#endif
-- ---------------------------------------------------------------------------
-- Turning on non-blocking for a file descriptor
-setNonBlockingFD :: FD -> IO ()
+setNonBlockingFD :: FD -> Bool -> IO ()
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-setNonBlockingFD fd = do
+setNonBlockingFD fd set = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
(c_fcntl_read fd const_f_getfl)
- -- An error when setting O_NONBLOCK isn't fatal: on some systems
- -- there are certain file handles on which this will fail (eg. /dev/null
- -- on FreeBSD) so we throw away the return code from fcntl_write.
- unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
- c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))
+ let flags' | set = flags .|. o_NONBLOCK
+ | otherwise = flags .&. complement o_NONBLOCK
+ unless (flags == flags') $ do
+ -- An error when setting O_NONBLOCK isn't fatal: on some systems
+ -- there are certain file handles on which this will fail (eg. /dev/null
+ -- on FreeBSD) so we throw away the return code from fcntl_write.
+ _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags')
return ()
#else
-- bogus defns for win32
-setNonBlockingFD _ = return ()
+setNonBlockingFD _ _ = return ()
+
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Set close-on-exec for a file descriptor
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+setCloseOnExec :: FD -> IO ()
+setCloseOnExec fd = do
+ throwErrnoIfMinus1_ "setCloseOnExec" $
+ c_fcntl_write fd const_f_setfd const_fd_cloexec
#endif
-- -----------------------------------------------------------------------------
-- foreign imports
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+type CFilePath = CString
+#else
+type CFilePath = CWString
+#endif
+
foreign import ccall unsafe "HsBase.h access"
c_access :: CString -> CInt -> IO CInt
foreign import ccall unsafe "HsBase.h close"
c_close :: CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h closedir"
- c_closedir :: Ptr CDir -> IO CInt
-
foreign import ccall unsafe "HsBase.h creat"
c_creat :: CString -> CMode -> IO CInt
#endif
foreign import ccall unsafe "HsBase.h __hscore_lstat"
- lstat :: CString -> Ptr CStat -> IO CInt
+ lstat :: CFilePath -> Ptr CStat -> IO CInt
foreign import ccall unsafe "HsBase.h __hscore_open"
- c_open :: CString -> CInt -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h opendir"
- c_opendir :: CString -> IO (Ptr CDir)
+ c_open :: CFilePath -> CInt -> CMode -> IO CInt
-foreign import ccall unsafe "HsBase.h __hscore_mkdir"
- mkdir :: CString -> CInt -> IO CInt
+foreign import ccall safe "HsBase.h __hscore_open"
+ c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt
foreign import ccall unsafe "HsBase.h read"
- c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+ c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
-foreign import ccall unsafe "HsBase.h rewinddir"
- c_rewinddir :: Ptr CDir -> IO ()
+foreign import ccall safe "HsBase.h read"
+ c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
foreign import ccall unsafe "HsBase.h __hscore_stat"
- c_stat :: CString -> Ptr CStat -> IO CInt
+ c_stat :: CFilePath -> Ptr CStat -> IO CInt
foreign import ccall unsafe "HsBase.h umask"
c_umask :: CMode -> IO CMode
foreign import ccall unsafe "HsBase.h write"
- c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+ c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+
+foreign import ccall safe "HsBase.h write"
+ c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
c_ftruncate :: CInt -> COff -> IO CInt
c_getpid :: IO CPid
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_read"
c_fcntl_read :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_write"
c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_lock"
c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
foreign import ccall unsafe "HsBase.h fork"
foreign import ccall unsafe "HsBase.h tcsetattr"
c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
-foreign import ccall unsafe "HsBase.h utime"
+foreign import ccall unsafe "HsBase.h __hscore_utime"
c_utime :: CString -> Ptr CUtimbuf -> IO CInt
foreign import ccall unsafe "HsBase.h waitpid"
c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
#endif
--- traversing directories
-foreign import ccall unsafe "dirUtils.h __hscore_readdir"
- readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_free_dirent"
- freeDirEnt :: Ptr CDirent -> IO ()
-
-foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"
- end_of_dir :: CInt
-
-foreign import ccall unsafe "HsBase.h __hscore_d_name"
- d_name :: Ptr CDirent -> IO CString
-
-- POSIX flags only:
foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sig_setmask" const_sig_setmask :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_getfl" const_f_getfl :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_setfl" const_f_setfl :: CInt
+foreign import ccall unsafe "HsBase.h __hscore_f_setfd" const_f_setfd :: CInt
+foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec" const_fd_cloexec :: CLong
#if defined(HTYPE_TCFLAG_T)
foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios" sizeof_termios :: Int
#else
s_issock _ = False
#endif
+
+foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
projects / ghc-base.git / blobdiff