{-# OPTIONS -fno-implicit-prelude #-}
--- ---------------------------------------------------------------------------
--- $Id: Posix.hs,v 1.1 2002/02/05 17:32:26 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Posix
+-- Copyright : (c) The University of Glasgow, 1992-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable
--
--- POSIX support layer for the standard libraries
+-- POSIX support layer for the standard libraries.
+-- This library is built on *every* platform, including Win32.
--
-- Non-posix compliant in order to support the following features:
-- * S_ISSOCK (no sockets in POSIX)
+--
+-----------------------------------------------------------------------------
module GHC.Posix where
#include "config.h"
import Control.Monad
+import System.Posix.Types
import Foreign
import Foreign.C
type CUtimbuf = ()
type CUtsname = ()
-type CDev = HTYPE_DEV_T
-type CIno = HTYPE_INO_T
-type CMode = HTYPE_MODE_T
-type COff = HTYPE_OFF_T
-type CPid = HTYPE_PID_T
-
-#ifdef mingw32_TARGET_OS
-type CSsize = HTYPE_SIZE_T
-#else
-type CGid = HTYPE_GID_T
-type CNlink = HTYPE_NLINK_T
-type CSsize = HTYPE_SSIZE_T
-type CUid = HTYPE_UID_T
-type CCc = HTYPE_CC_T
-type CSpeed = HTYPE_SPEED_T
-type CTcflag = HTYPE_TCFLAG_T
-#endif
-
-- ---------------------------------------------------------------------------
-- stat()-related stuff
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
- _ | s_isdir c_mode -> return Directory
- | s_isfifo c_mode || s_issock c_mode -> return Stream
- | s_isreg c_mode -> return RegularFile
- | otherwise -> ioException ioe_unknownfiletype
+ _ | s_isdir c_mode -> return Directory
+ | s_isfifo c_mode || s_issock c_mode || s_ischr c_mode
+ -> return Stream
+ | s_isreg c_mode -> return RegularFile
+ | otherwise -> ioException ioe_unknownfiletype
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
| isStream = c_closesocket fd
| otherwise = c_close fd
-foreign import ccall unsafe "closesocket"
+foreign import stdcall unsafe "closesocket"
c_closesocket :: CInt -> IO CInt
#endif
+fdGetMode :: Int -> IO IOMode
+fdGetMode fd = do
+#ifdef mingw32_TARGET_OS
+ flags1 <- throwErrnoIfMinus1Retry "fdGetMode"
+ (c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
+ flags <- throwErrnoIfMinus1Retry "fdGetMode"
+ (c__setmode (fromIntegral fd) (fromIntegral flags1))
+#else
+ flags <- throwErrnoIfMinus1Retry "fdGetMode"
+ (c_fcntl_read (fromIntegral fd) const_f_getfl)
+#endif
+ let
+ wH = (flags .&. o_WRONLY) /= 0
+ aH = (flags .&. o_APPEND) /= 0
+ rwH = (flags .&. o_RDWR) /= 0
+
+ mode
+ | wH && aH = AppendMode
+ | wH = WriteMode
+ | rwH = ReadWriteMode
+ | otherwise = ReadMode
+
+ return mode
+
-- ---------------------------------------------------------------------------
-- Terminal-related stuff
poke_c_lflag p_tios (new_c_lflag :: CTcflag)
-- set VMIN & VTIME to 1/0 respectively
- when cooked $ do
+ when (not cooked) $ do
c_cc <- ptr_c_cc p_tios
let vmin = (c_cc `plusPtr` (fromIntegral const_vmin)) :: Ptr Word8
vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
throwErrnoIfMinus1Retry_ "tcSetAttr" $
c_tcsetattr (fromIntegral fd) options p_tios
c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+ return ()
#else
--- bogus defns for win32
+-- 'raw' mode for Win32 means turn off 'line input' (=> buffering and
+-- character translation for the console.) The Win32 API for doing
+-- this is GetConsoleMode(), which also requires echoing to be disabled
+-- when turning off 'line input' processing. Notice that turning off
+-- 'line input' implies enter/return is reported as '\r' (and it won't
+-- report that character until another character is input..odd.) This
+-- latter feature doesn't sit too well with IO actions like IO.hGetLine..
+-- consider yourself warned.
setCooked :: Int -> Bool -> IO ()
-setCooked fd cooked = return ()
+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")
+ else return ()
+ioe_unk_error loc msg
+ = IOError Nothing OtherError loc msg Nothing
+
+-- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
+-- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
setEcho :: Int -> Bool -> IO ()
-setEcho fd on = return ()
+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")
+ else return ()
getEcho :: Int -> IO Bool
-getEcho fd = return False
+getEcho fd = do
+ r <- get_console_echo (fromIntegral fd)
+ if (r == (-1))
+ then ioException (ioe_unk_error "getEcho" "failed to get echoing")
+ else return (r == 1)
+
+foreign import ccall unsafe "consUtils.h set_console_buffering__"
+ set_console_buffering :: CInt -> CInt -> IO CInt
+
+foreign import ccall unsafe "consUtils.h set_console_echo__"
+ set_console_echo :: CInt -> CInt -> IO CInt
+
+foreign import ccall unsafe "consUtils.h get_console_echo__"
+ get_console_echo :: CInt -> IO CInt
#endif
foreign import ccall unsafe "chdir"
c_chdir :: CString -> IO CInt
-foreign import ccall unsafe "chown"
- c_chown :: CString -> CUid -> CGid -> IO CInt
-
foreign import ccall unsafe "close"
c_close :: CInt -> IO CInt
foreign import ccall unsafe "dup2"
c_dup2 :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "fpathconf"
- c_fpathconf :: CInt -> CInt -> IO CLong
-
foreign import ccall unsafe "fstat"
c_fstat :: CInt -> Ptr CStat -> IO CInt
foreign import ccall unsafe "isatty"
c_isatty :: CInt -> IO CInt
-foreign import ccall unsafe "link"
- c_link :: CString -> CString -> IO CInt
-
foreign import ccall unsafe "lseek"
c_lseek :: CInt -> COff -> CInt -> IO COff
foreign import ccall unsafe "__hscore_mkdir"
mkdir :: CString -> CInt -> IO CInt
-foreign import ccall unsafe "mkfifo"
- c_mkfifo :: CString -> CMode -> IO CInt
-
-foreign import ccall unsafe "pathconf"
- c_pathconf :: CString -> CInt -> IO CLong
-
-foreign import ccall unsafe "pipe"
- c_pipe :: Ptr CInt -> IO CInt
-
foreign import ccall unsafe "read"
c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
foreign import ccall unsafe "umask"
c_umask :: CMode -> IO CMode
-foreign import ccall unsafe "utime"
- c_utime :: CString -> Ptr CUtimbuf -> IO CMode
-
foreign import ccall unsafe "write"
c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+foreign import ccall unsafe "unlink"
+ c_unlink :: CString -> IO CInt
+
#ifndef mingw32_TARGET_OS
foreign import ccall unsafe "fcntl"
c_fcntl_read :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "fork"
c_fork :: IO CPid
+foreign import ccall unsafe "getpid"
+ c_getpid :: IO CPid
+
+foreign import ccall unsafe "fpathconf"
+ c_fpathconf :: CInt -> CInt -> IO CLong
+
+foreign import ccall unsafe "link"
+ c_link :: CString -> CString -> IO CInt
+
+foreign import ccall unsafe "mkfifo"
+ c_mkfifo :: CString -> CMode -> IO CInt
+
+foreign import ccall unsafe "pathconf"
+ c_pathconf :: CString -> CInt -> IO CLong
+
+foreign import ccall unsafe "pipe"
+ c_pipe :: Ptr CInt -> IO CInt
+
foreign import ccall unsafe "__hscore_sigemptyset"
- c_sigemptyset :: Ptr CSigset -> IO ()
+ c_sigemptyset :: Ptr CSigset -> IO CInt
-foreign import ccall unsafe "sigaddset"
- c_sigaddset :: Ptr CSigset -> CInt -> IO ()
+foreign import ccall unsafe "__hscore_sigaddset"
+ c_sigaddset :: Ptr CSigset -> CInt -> IO CInt
foreign import ccall unsafe "sigprocmask"
- c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
+ c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt
foreign import ccall unsafe "tcgetattr"
c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
foreign import ccall unsafe "tcsetattr"
c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
-foreign import ccall unsafe "uname"
- c_uname :: Ptr CUtsname -> IO CInt
-
-foreign import ccall unsafe "unlink"
- c_unlink :: CString -> IO CInt
+foreign import ccall unsafe "utime"
+ c_utime :: CString -> Ptr CUtimbuf -> IO CMode
foreign import ccall unsafe "waitpid"
c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
+#else
+foreign import ccall unsafe "_setmode"
+ c__setmode :: CInt -> CInt -> IO CInt
+
+-- /* Set "stdin" to have binary mode: */
+-- result = _setmode( _fileno( stdin ), _O_BINARY );
+-- if( result == -1 )
+-- perror( "Cannot set mode" );
+-- else
+-- printf( "'stdin' successfully changed to binary mode\n" );
#endif
-- POSIX flags only:
foreign import ccall unsafe "__hscore_st_size" st_size :: Ptr CStat -> IO COff
foreign import ccall unsafe "__hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
-foreign import ccall unsafe "__hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
-foreign import ccall unsafe "__hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
-foreign import ccall unsafe "__hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
-
foreign import ccall unsafe "__hscore_echo" const_echo :: CInt
foreign import ccall unsafe "__hscore_tcsanow" const_tcsanow :: CInt
foreign import ccall unsafe "__hscore_icanon" const_icanon :: CInt
#ifndef mingw32_TARGET_OS
foreign import ccall unsafe "__hscore_sizeof_termios" sizeof_termios :: Int
foreign import ccall unsafe "__hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
+
+foreign import ccall unsafe "__hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
+foreign import ccall unsafe "__hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
+foreign import ccall unsafe "__hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
#endif
#ifndef mingw32_TARGET_OS
projects / ghc-base.git / blobdiff