-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
-----------------------------------------------------------------------------
-- |
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
--- Portability : non-portable
+-- Portability : non-portable (requires POSIX)
--
-- POSIX support layer for the standard libraries.
-- This library is built on *every* platform, including Win32.
-- #hide
module System.Posix.Internals where
-#include "config.h"
+#include "ghcconfig.h"
+#include "HsBaseConfig.h"
import Control.Monad
import System.Posix.Types
#ifdef __HUGS__
import Hugs.Prelude (IOException(..), IOErrorType(..))
-{-# CBITS PrelIOUtils.c #-}
+{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
#endif
-- ---------------------------------------------------------------------------
c_size <- st_size p_stat :: IO COff
return (fromIntegral c_size)
-data FDType = Directory | Stream | RegularFile
+data FDType = Directory | Stream | RegularFile | RawDevice
deriving (Eq)
fileType :: FilePath -> IO FDType
| s_isfifo c_mode || s_issock c_mode || s_ischr c_mode
-> return Stream
| s_isreg c_mode -> return RegularFile
+ -- Q: map char devices to RawDevice too?
+ | s_isblk c_mode -> return RawDevice
| otherwise -> ioError ioe_unknownfiletype
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
"unknown file type" Nothing
--- It isn't clear whether ftruncate is POSIX or not (I've read several
--- manpages and they seem to conflict), so we truncate using open/2.
-fileTruncate :: FilePath -> IO ()
-fileTruncate file = do
- let flags = o_WRONLY .|. o_TRUNC
- withCString file $ \file_cstr -> do
- fd <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "fileTruncate"
- (c_open file_cstr (fromIntegral flags) 0o666)
- c_close fd
- return ()
-
-#ifdef mingw32_TARGET_OS
+#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
closeFd :: Bool -> CInt -> IO CInt
closeFd isStream fd
| isStream = c_closesocket fd
fdGetMode :: Int -> IO IOMode
fdGetMode fd = do
-#ifdef mingw32_TARGET_OS
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+ -- XXX: this code is *BROKEN*, _setmode only deals with O_TEXT/O_BINARY
flags1 <- throwErrnoIfMinus1Retry "fdGetMode"
(c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
flags <- throwErrnoIfMinus1Retry "fdGetMode"
fdIsTTY :: Int -> IO Bool
fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
-#ifndef mingw32_TARGET_OS
+#if defined(HTYPE_TCFLAG_T)
setEcho :: Int -> Bool -> IO ()
setEcho fd on = do
- allocaBytes sizeof_termios $ \p_tios -> do
- throwErrnoIfMinus1Retry "setEcho"
- (c_tcgetattr (fromIntegral fd) p_tios)
+ tcSetAttr fd $ \ p_tios -> do
c_lflag <- c_lflag p_tios :: IO CTcflag
let new_c_lflag
| on = c_lflag .|. fromIntegral const_echo
| otherwise = c_lflag .&. complement (fromIntegral const_echo)
poke_c_lflag p_tios (new_c_lflag :: CTcflag)
- tcSetAttr fd const_tcsanow p_tios
getEcho :: Int -> IO Bool
getEcho fd = do
- allocaBytes sizeof_termios $ \p_tios -> do
- throwErrnoIfMinus1Retry "setEcho"
- (c_tcgetattr (fromIntegral fd) p_tios)
+ tcSetAttr fd $ \ p_tios -> do
c_lflag <- c_lflag p_tios :: IO CTcflag
return ((c_lflag .&. fromIntegral const_echo) /= 0)
setCooked :: Int -> Bool -> IO ()
setCooked fd cooked =
- allocaBytes sizeof_termios $ \p_tios -> do
- throwErrnoIfMinus1Retry "setCooked"
- (c_tcgetattr (fromIntegral fd) p_tios)
+ tcSetAttr fd $ \ p_tios -> do
-- turn on/off ICANON
c_lflag <- c_lflag p_tios :: IO CTcflag
poke vmin 1
poke vtime 0
- tcSetAttr fd const_tcsanow p_tios
-
--- tcsetattr() when invoked by a background process causes the process
--- to be sent SIGTTOU regardless of whether the process has TOSTOP set
--- in its terminal flags (try it...). This function provides a
--- wrapper which temporarily blocks SIGTTOU around the call, making it
--- transparent.
-
-tcSetAttr :: FD -> CInt -> Ptr CTermios -> IO ()
-tcSetAttr fd options p_tios = do
- 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
- throwErrnoIfMinus1Retry_ "tcSetAttr" $
- c_tcsetattr (fromIntegral fd) options p_tios
- c_sigprocmask const_sig_setmask p_old_sigset nullPtr
- return ()
+tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
+tcSetAttr fd fun = do
+ allocaBytes sizeof_termios $ \p_tios -> do
+ throwErrnoIfMinus1Retry "tcSetAttr"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+
+#ifdef __GLASGOW_HASKELL__
+ -- Save a copy of termios, if this is a standard file descriptor.
+ -- These terminal settings are restored in hs_exit().
+ when (fd <= 2) $ do
+ p <- get_saved_termios fd
+ when (p == nullPtr) $ do
+ saved_tios <- mallocBytes sizeof_termios
+ copyBytes saved_tios p_tios sizeof_termios
+ set_saved_termios fd saved_tios
+#endif
+
+ -- tcsetattr() when invoked by a background process causes the process
+ -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
+ -- in its terminal flags (try it...). This function provides a
+ -- 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
+ r <- fun p_tios -- do the business
+ throwErrnoIfMinus1Retry_ "tcSetAttr" $
+ c_tcsetattr (fromIntegral fd) const_tcsanow p_tios
+ c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+ return r
+
+#ifdef __GLASGOW_HASKELL__
+foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
+ get_saved_termios :: Int -> IO (Ptr CTermios)
+
+foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"
+ set_saved_termios :: Int -> (Ptr CTermios) -> IO ()
+#endif
#else
setCooked fd cooked = do
x <- set_console_buffering (fromIntegral fd) (if cooked then 1 else 0)
if (x /= 0)
- then ioException (ioe_unk_error "setCooked" "failed to set buffering")
+ then ioError (ioe_unk_error "setCooked" "failed to set buffering")
else return ()
ioe_unk_error loc msg
setEcho fd on = do
x <- set_console_echo (fromIntegral fd) (if on then 1 else 0)
if (x /= 0)
- then ioException (ioe_unk_error "setEcho" "failed to set echoing")
+ then ioError (ioe_unk_error "setEcho" "failed to set echoing")
else return ()
getEcho :: Int -> IO Bool
getEcho fd = do
r <- get_console_echo (fromIntegral fd)
if (r == (-1))
- then ioException (ioe_unk_error "getEcho" "failed to get echoing")
+ then ioError (ioe_unk_error "getEcho" "failed to get echoing")
else return (r == 1)
-foreign import ccall unsafe "HsBase.h consUtils.h set_console_buffering__"
+foreign import ccall unsafe "consUtils.h set_console_buffering__"
set_console_buffering :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h consUtils.h set_console_echo__"
+foreign import ccall unsafe "consUtils.h set_console_echo__"
set_console_echo :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h consUtils.h get_console_echo__"
+foreign import ccall unsafe "consUtils.h get_console_echo__"
get_console_echo :: CInt -> IO CInt
#endif
-- ---------------------------------------------------------------------------
-- Turning on non-blocking for a file descriptor
-#ifndef mingw32_TARGET_OS
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
-- 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 (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
+ unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
+ c_fcntl_write (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
+ return ()
#else
-- bogus defns for win32
foreign import ccall unsafe "HsBase.h dup2"
c_dup2 :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h fstat"
+foreign import ccall unsafe "HsBase.h __hscore_fstat"
c_fstat :: CInt -> Ptr CStat -> IO CInt
foreign import ccall unsafe "HsBase.h getcwd"
foreign import ccall unsafe "HsBase.h isatty"
c_isatty :: CInt -> IO CInt
-foreign import ccall unsafe "HsBase.h lseek"
+foreign import ccall unsafe "HsBase.h __hscore_lseek"
c_lseek :: CInt -> COff -> CInt -> IO COff
foreign import ccall unsafe "HsBase.h __hscore_lstat"
lstat :: CString -> Ptr CStat -> IO CInt
-foreign import ccall unsafe "HsBase.h open"
+foreign import ccall unsafe "HsBase.h __hscore_open"
c_open :: CString -> CInt -> CMode -> IO CInt
foreign import ccall unsafe "HsBase.h opendir"
foreign import ccall unsafe "HsBase.h read"
c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
-foreign import ccall unsafe "HsBase.h readdir"
- c_readdir :: Ptr CDir -> IO (Ptr CDirent)
-
-foreign import ccall unsafe "HsBase.h rename"
+foreign import ccall unsafe "dirUtils.h __hscore_renameFile"
c_rename :: CString -> CString -> IO CInt
foreign import ccall unsafe "HsBase.h rewinddir"
foreign import ccall unsafe "HsBase.h rmdir"
c_rmdir :: CString -> IO CInt
-foreign import ccall unsafe "HsBase.h stat"
+foreign import ccall unsafe "HsBase.h __hscore_stat"
c_stat :: CString -> Ptr CStat -> IO CInt
foreign import ccall unsafe "HsBase.h umask"
foreign import ccall unsafe "HsBase.h write"
c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
+ c_ftruncate :: CInt -> COff -> IO CInt
+
foreign import ccall unsafe "HsBase.h unlink"
c_unlink :: CString -> IO CInt
-#ifndef mingw32_TARGET_OS
+foreign import ccall unsafe "HsBase.h getpid"
+ c_getpid :: IO CPid
+
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
foreign import ccall unsafe "HsBase.h fcntl"
c_fcntl_read :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "HsBase.h fork"
c_fork :: IO CPid
-foreign import ccall unsafe "HsBase.h getpid"
- c_getpid :: IO CPid
-
-foreign import ccall unsafe "HsBase.h fpathconf"
- c_fpathconf :: CInt -> CInt -> IO CLong
-
foreign import ccall unsafe "HsBase.h link"
c_link :: CString -> CString -> IO CInt
foreign import ccall unsafe "HsBase.h mkfifo"
c_mkfifo :: CString -> CMode -> IO CInt
-foreign import ccall unsafe "HsBase.h pathconf"
- c_pathconf :: CString -> CInt -> IO CLong
-
foreign import ccall unsafe "HsBase.h pipe"
c_pipe :: Ptr CInt -> IO CInt
-- printf( "'stdin' successfully changed to binary mode\n" );
#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_f_getfl" const_f_getfl :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_setfl" const_f_setfl :: CInt
-#ifndef mingw32_TARGET_OS
+#if defined(HTYPE_TCFLAG_T)
foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios" sizeof_termios :: Int
foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
#endif
-#ifndef mingw32_TARGET_OS
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
foreign import ccall unsafe "HsBase.h __hscore_s_issock" s_issock :: CMode -> Bool
#else
s_issock :: CMode -> Bool
projects / haskell-directory.git / blobdiff