1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
3 -- ---------------------------------------------------------------------------
4 -- $Id: PrelPosix.hsc,v 1.6 2001/06/05 16:21:25 sewardj Exp $
6 -- POSIX support layer for the standard libraries
8 -- NON_POSIX_SOURCE needed for the following features:
9 -- * S_ISSOCK (no sockets in POSIX)
11 module PrelPosix where
27 import PrelMarshalAlloc
28 import PrelMarshalUtils
34 -- ---------------------------------------------------------------------------
40 type CDev = #type dev_t
41 type CIno = #type ino_t
42 type CMode = #type mode_t
43 type COff = #type off_t
44 type CPid = #type pid_t
46 #ifdef mingw32_TARGET_OS
47 type CSsize = #type size_t
49 type CGid = #type gid_t
50 type CNlink = #type nlink_t
51 type CSsize = #type ssize_t
52 type CUid = #type uid_t
54 type CSpeed = #type speed_t
55 type CTcflag = #type tcflag_t
58 -- ---------------------------------------------------------------------------
59 -- stat()-related stuff
63 fdFileSize :: Int -> IO Integer
65 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
66 throwErrnoIfMinus1Retry "fileSize" $
67 c_fstat (fromIntegral fd) p_stat
68 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
69 if not (s_isreg c_mode)
72 c_size <- (#peek struct stat, st_size) p_stat :: IO COff
73 return (fromIntegral c_size)
75 data FDType = Directory | Stream | RegularFile
78 fdType :: Int -> IO FDType
80 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
81 throwErrnoIfMinus1Retry "fileSize" $
82 c_fstat (fromIntegral fd) p_stat
83 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
85 _ | s_isdir c_mode -> return Directory
86 | s_isfifo c_mode || s_issock c_mode -> return Stream
87 | s_isreg c_mode -> return RegularFile
88 | otherwise -> ioException ioe_unknownfiletype
90 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
91 "unknown file type" Nothing
93 foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
94 #def inline int s_isreg_wrap(m) { return S_ISREG(m); }
96 foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
97 #def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
99 foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
100 #def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
102 #ifndef mingw32_TARGET_OS
103 foreign import "s_issock_wrap" s_issock :: CMode -> Bool
104 #def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
106 s_issock :: CMode -> Bool
107 s_issock cmode = False
109 -- ---------------------------------------------------------------------------
110 -- Terminal-related stuff
112 fdIsTTY :: Int -> IO Bool
113 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
115 #ifndef mingw32_TARGET_OS
119 setEcho :: Int -> Bool -> IO ()
121 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
122 throwErrnoIfMinus1Retry "setEcho"
123 (c_tcgetattr (fromIntegral fd) p_tios)
124 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
125 let new_c_lflag | on = c_lflag .|. (#const ECHO)
126 | otherwise = c_lflag .&. complement (#const ECHO)
127 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
128 tcSetAttr fd (#const TCSANOW) p_tios
130 getEcho :: Int -> IO Bool
132 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
133 throwErrnoIfMinus1Retry "setEcho"
134 (c_tcgetattr (fromIntegral fd) p_tios)
135 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
136 return ((c_lflag .&. (#const ECHO)) /= 0)
138 setCooked :: Int -> Bool -> IO ()
139 setCooked fd cooked =
140 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
141 throwErrnoIfMinus1Retry "setCooked"
142 (c_tcgetattr (fromIntegral fd) p_tios)
144 -- turn on/off ICANON
145 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
146 let new_c_lflag | cooked = c_lflag .|. (#const ICANON)
147 | otherwise = c_lflag .&. complement (#const ICANON)
148 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
150 -- set VMIN & VTIME to 1/0 respectively
152 let c_cc = (#ptr struct termios, c_cc) p_tios
153 vmin = c_cc `plusPtr` (#const VMIN) :: Ptr Word8
154 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
158 tcSetAttr fd (#const TCSANOW) p_tios
160 -- tcsetattr() when invoked by a background process causes the process
161 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
162 -- in its terminal flags (try it...). This function provides a
163 -- wrapper which temporarily blocks SIGTTOU around the call, making it
166 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
167 tcSetAttr fd options p_tios = do
168 allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
169 allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
170 c_sigemptyset p_sigset
171 c_sigaddset p_sigset (#const SIGTTOU)
172 c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
173 throwErrnoIfMinus1Retry_ "tcSetAttr" $
174 c_tcsetattr (fromIntegral fd) options p_tios
175 c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
179 -- bogus defns for win32
180 setCooked :: Int -> Bool -> IO ()
181 setCooked fd cooked = return ()
183 setEcho :: Int -> Bool -> IO ()
184 setEcho fd on = return ()
186 getEcho :: Int -> IO Bool
187 getEcho fd = return False
191 -- ---------------------------------------------------------------------------
192 -- Turning on non-blocking for a file descriptor
194 #ifndef mingw32_TARGET_OS
196 setNonBlockingFD fd = do
197 flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
198 (fcntl_read (fromIntegral fd) (#const F_GETFL))
199 throwErrnoIfMinus1Retry "setNonBlockingFD"
200 (fcntl_write (fromIntegral fd)
201 (#const F_SETFL) (flags .|. #const O_NONBLOCK))
204 -- bogus defns for win32
205 setNonBlockingFD fd = return ()
209 -- -----------------------------------------------------------------------------
212 foreign import "stat" unsafe
213 c_stat :: CString -> Ptr CStat -> IO CInt
215 foreign import "fstat" unsafe
216 c_fstat :: CInt -> Ptr CStat -> IO CInt
219 foreign import "lstat" unsafe
220 c_lstat :: CString -> Ptr CStat -> IO CInt
223 foreign import "open" unsafe
224 c_open :: CString -> CInt -> CMode -> IO CInt
227 o_RDONLY = (#const O_RDONLY) :: CInt
228 o_WRONLY = (#const O_WRONLY) :: CInt
229 o_RDWR = (#const O_RDWR) :: CInt
230 o_APPEND = (#const O_APPEND) :: CInt
231 o_CREAT = (#const O_CREAT) :: CInt
232 o_EXCL = (#const O_EXCL) :: CInt
233 o_TRUNC = (#const O_TRUNC) :: CInt
235 #ifdef mingw32_TARGET_OS
237 o_NONBLOCK = 0 :: CInt
239 o_NOCTTY = (#const O_NOCTTY) :: CInt
240 o_NONBLOCK = (#const O_NONBLOCK) :: CInt
244 o_BINARY = (#const O_BINARY) :: CInt
247 foreign import "isatty" unsafe
248 c_isatty :: CInt -> IO CInt
250 foreign import "close" unsafe
251 c_close :: CInt -> IO CInt
253 foreign import "lseek" unsafe
254 c_lseek :: CInt -> COff -> CInt -> IO COff
256 foreign import "write" unsafe
257 c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
259 foreign import "read" unsafe
260 c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
262 #ifndef mingw32_TARGET_OS
263 foreign import "fcntl" unsafe
264 fcntl_read :: CInt -> CInt -> IO CInt
266 foreign import "fcntl" unsafe
267 fcntl_write :: CInt -> CInt -> CInt -> IO CInt
269 foreign import "fork" unsafe
272 foreign import "sigemptyset" unsafe
273 c_sigemptyset :: Ptr CSigset -> IO ()
275 foreign import "sigaddset" unsafe
276 c_sigaddset :: Ptr CSigset -> CInt -> IO ()
278 foreign import "sigprocmask" unsafe
279 c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
281 foreign import "tcgetattr" unsafe
282 c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
284 foreign import "tcsetattr" unsafe
285 c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
287 foreign import "waitpid" unsafe
288 c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid