1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
3 -- ---------------------------------------------------------------------------
4 -- $Id: Posix.hsc,v 1.2 2001/07/31 12:48:13 simonmar 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 GHC.Posix where
28 -- ---------------------------------------------------------------------------
34 type CDev = #type dev_t
35 type CIno = #type ino_t
36 type CMode = #type mode_t
37 type COff = #type off_t
38 type CPid = #type pid_t
40 #ifdef mingw32_TARGET_OS
41 type CSsize = #type size_t
43 type CGid = #type gid_t
44 type CNlink = #type nlink_t
45 type CSsize = #type ssize_t
46 type CUid = #type uid_t
48 type CSpeed = #type speed_t
49 type CTcflag = #type tcflag_t
52 -- ---------------------------------------------------------------------------
53 -- stat()-related stuff
57 fdFileSize :: Int -> IO Integer
59 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
60 throwErrnoIfMinus1Retry "fdFileSize" $
61 c_fstat (fromIntegral fd) p_stat
62 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
63 if not (s_isreg c_mode)
66 c_size <- (#peek struct stat, st_size) p_stat :: IO COff
67 return (fromIntegral c_size)
69 data FDType = Directory | Stream | RegularFile
72 fileType :: FilePath -> IO FDType
74 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
75 withCString file $ \p_file -> do
76 throwErrnoIfMinus1Retry "fileType" $
80 fdType :: Int -> IO FDType
82 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
83 throwErrnoIfMinus1Retry "fdType" $
84 c_fstat (fromIntegral fd) p_stat
87 statGetType p_stat = do
88 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
90 _ | s_isdir c_mode -> return Directory
91 | s_isfifo c_mode || s_issock c_mode -> return Stream
92 | s_isreg c_mode -> return RegularFile
93 | otherwise -> ioException ioe_unknownfiletype
96 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
97 "unknown file type" Nothing
99 foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
100 #def inline int s_isreg_wrap(m) { return S_ISREG(m); }
102 foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
103 #def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
105 foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
106 #def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
108 #ifndef mingw32_TARGET_OS
109 foreign import "s_issock_wrap" s_issock :: CMode -> Bool
110 #def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
112 s_issock :: CMode -> Bool
113 s_issock cmode = False
116 -- It isn't clear whether ftruncate is POSIX or not (I've read several
117 -- manpages and they seem to conflict), so we truncate using open/2.
118 fileTruncate :: FilePath -> IO ()
119 fileTruncate file = do
120 let flags = o_WRONLY .|. o_TRUNC
121 withCString file $ \file_cstr -> do
122 fd <- fromIntegral `liftM`
123 throwErrnoIfMinus1Retry "fileTruncate"
124 (c_open file_cstr (fromIntegral flags) 0o666)
128 -- ---------------------------------------------------------------------------
129 -- Terminal-related stuff
131 fdIsTTY :: Int -> IO Bool
132 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
134 #ifndef mingw32_TARGET_OS
138 setEcho :: Int -> Bool -> IO ()
140 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
141 throwErrnoIfMinus1Retry "setEcho"
142 (c_tcgetattr (fromIntegral fd) p_tios)
143 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
144 let new_c_lflag | on = c_lflag .|. (#const ECHO)
145 | otherwise = c_lflag .&. complement (#const ECHO)
146 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
147 tcSetAttr fd (#const TCSANOW) p_tios
149 getEcho :: Int -> IO Bool
151 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
152 throwErrnoIfMinus1Retry "setEcho"
153 (c_tcgetattr (fromIntegral fd) p_tios)
154 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
155 return ((c_lflag .&. (#const ECHO)) /= 0)
157 setCooked :: Int -> Bool -> IO ()
158 setCooked fd cooked =
159 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
160 throwErrnoIfMinus1Retry "setCooked"
161 (c_tcgetattr (fromIntegral fd) p_tios)
163 -- turn on/off ICANON
164 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
165 let new_c_lflag | cooked = c_lflag .|. (#const ICANON)
166 | otherwise = c_lflag .&. complement (#const ICANON)
167 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
169 -- set VMIN & VTIME to 1/0 respectively
171 let c_cc = (#ptr struct termios, c_cc) p_tios
172 vmin = c_cc `plusPtr` (#const VMIN) :: Ptr Word8
173 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
177 tcSetAttr fd (#const TCSANOW) p_tios
179 -- tcsetattr() when invoked by a background process causes the process
180 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
181 -- in its terminal flags (try it...). This function provides a
182 -- wrapper which temporarily blocks SIGTTOU around the call, making it
185 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
186 tcSetAttr fd options p_tios = do
187 allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
188 allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
189 c_sigemptyset p_sigset
190 c_sigaddset p_sigset (#const SIGTTOU)
191 c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
192 throwErrnoIfMinus1Retry_ "tcSetAttr" $
193 c_tcsetattr (fromIntegral fd) options p_tios
194 c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
198 -- bogus defns for win32
199 setCooked :: Int -> Bool -> IO ()
200 setCooked fd cooked = return ()
202 setEcho :: Int -> Bool -> IO ()
203 setEcho fd on = return ()
205 getEcho :: Int -> IO Bool
206 getEcho fd = return False
210 -- ---------------------------------------------------------------------------
211 -- Turning on non-blocking for a file descriptor
213 #ifndef mingw32_TARGET_OS
215 setNonBlockingFD fd = do
216 flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
217 (fcntl_read (fromIntegral fd) (#const F_GETFL))
218 throwErrnoIfMinus1Retry "setNonBlockingFD"
219 (fcntl_write (fromIntegral fd)
220 (#const F_SETFL) (flags .|. #const O_NONBLOCK))
223 -- bogus defns for win32
224 setNonBlockingFD fd = return ()
228 -- -----------------------------------------------------------------------------
231 foreign import "stat" unsafe
232 c_stat :: CString -> Ptr CStat -> IO CInt
234 foreign import "fstat" unsafe
235 c_fstat :: CInt -> Ptr CStat -> IO CInt
238 foreign import "lstat" unsafe
239 c_lstat :: CString -> Ptr CStat -> IO CInt
242 foreign import "open" unsafe
243 c_open :: CString -> CInt -> CMode -> IO CInt
246 o_RDONLY = (#const O_RDONLY) :: CInt
247 o_WRONLY = (#const O_WRONLY) :: CInt
248 o_RDWR = (#const O_RDWR) :: CInt
249 o_APPEND = (#const O_APPEND) :: CInt
250 o_CREAT = (#const O_CREAT) :: CInt
251 o_EXCL = (#const O_EXCL) :: CInt
252 o_TRUNC = (#const O_TRUNC) :: CInt
254 #ifdef mingw32_TARGET_OS
256 o_NONBLOCK = 0 :: CInt
258 o_NOCTTY = (#const O_NOCTTY) :: CInt
259 o_NONBLOCK = (#const O_NONBLOCK) :: CInt
263 o_BINARY = (#const O_BINARY) :: CInt
266 foreign import "isatty" unsafe
267 c_isatty :: CInt -> IO CInt
269 foreign import "close" unsafe
270 c_close :: CInt -> IO CInt
272 foreign import "lseek" unsafe
273 c_lseek :: CInt -> COff -> CInt -> IO COff
275 foreign import "write" unsafe
276 c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
278 foreign import "read" unsafe
279 c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
281 #ifndef mingw32_TARGET_OS
282 foreign import "fcntl" unsafe
283 fcntl_read :: CInt -> CInt -> IO CInt
285 foreign import "fcntl" unsafe
286 fcntl_write :: CInt -> CInt -> CInt -> IO CInt
288 foreign import "fork" unsafe
291 foreign import "sigemptyset" unsafe
292 c_sigemptyset :: Ptr CSigset -> IO ()
294 foreign import "sigaddset" unsafe
295 c_sigaddset :: Ptr CSigset -> CInt -> IO ()
297 foreign import "sigprocmask" unsafe
298 c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
300 foreign import "tcgetattr" unsafe
301 c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
303 foreign import "tcsetattr" unsafe
304 c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
306 foreign import "unlink" unsafe
307 c_unlink :: CString -> IO CInt
309 foreign import "waitpid" unsafe
310 c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid