1 {-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
3 -- ---------------------------------------------------------------------------
5 -- POSIX support layer for the standard libraries
7 -- Non-posix compliant in order to support the following features:
8 -- * S_ISSOCK (no sockets in POSIX)
10 module PrelPosix where
12 -- See above comment for non-Posixness reasons.
13 -- #include "PosixSource.h"
29 import PrelMarshalAlloc
30 import PrelMarshalUtils
36 -- ---------------------------------------------------------------------------
42 type CDev = #type dev_t
43 type CIno = #type ino_t
44 type CMode = #type mode_t
45 type COff = #type off_t
46 type CPid = #type pid_t
48 #ifdef mingw32_TARGET_OS
49 type CSsize = #type size_t
51 type CGid = #type gid_t
52 type CNlink = #type nlink_t
53 type CSsize = #type ssize_t
54 type CUid = #type uid_t
56 type CSpeed = #type speed_t
57 type CTcflag = #type tcflag_t
60 -- ---------------------------------------------------------------------------
61 -- stat()-related stuff
65 fdFileSize :: Int -> IO Integer
67 allocaBytes sizeof_stat $ \ p_stat -> do
68 throwErrnoIfMinus1Retry "fileSize" $
69 c_fstat (fromIntegral fd) p_stat
70 c_mode <- st_mode p_stat :: IO CMode
71 if not (s_isreg c_mode)
74 c_size <- st_size p_stat :: IO COff
75 return (fromIntegral c_size)
77 data FDType = Directory | Stream | RegularFile
80 -- NOTE: On Win32 platforms, this will only work with file descriptors
81 -- referring to file handles. i.e., it'll fail for socket FDs.
82 fdType :: Int -> IO FDType
84 allocaBytes sizeof_stat $ \ p_stat -> do
85 throwErrnoIfMinus1Retry "fdType" $
86 c_fstat (fromIntegral fd) p_stat
87 c_mode <- st_mode p_stat :: IO CMode
89 _ | s_isdir c_mode -> return Directory
90 | s_isfifo c_mode -> return Stream
91 | s_issock c_mode -> return Stream
92 | s_ischr c_mode -> return Stream
93 | s_isreg c_mode -> return RegularFile
94 | s_isblk c_mode -> return RegularFile
95 | otherwise -> ioException ioe_unknownfiletype
96 -- we consider character devices to be streams (eg. ttys),
97 -- whereas block devices are more like regular files because they
100 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
101 "unknown file type" Nothing
103 foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
104 foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
105 foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
106 foreign import "s_ischr_PrelPosix_wrap" unsafe s_ischr :: CMode -> Bool
107 foreign import "s_isblk_PrelPosix_wrap" unsafe s_isblk :: CMode -> Bool
109 #ifndef mingw32_TARGET_OS
110 foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
113 s_issock :: CMode -> Bool
114 s_issock cmode = False
117 -- It isn't clear whether ftruncate is POSIX or not (I've read several
118 -- manpages and they seem to conflict), so we truncate using open/2.
119 fileTruncate :: FilePath -> IO ()
120 fileTruncate file = do
121 let flags = o_WRONLY .|. o_TRUNC
122 withCString file $ \file_cstr -> do
123 fd <- fromIntegral `liftM`
124 throwErrnoIfMinus1Retry "fileTruncate"
125 (c_open file_cstr (fromIntegral flags) 0o666)
129 -- ---------------------------------------------------------------------------
130 -- Terminal-related stuff
132 fdIsTTY :: Int -> IO Bool
133 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
135 #ifndef mingw32_TARGET_OS
139 setEcho :: Int -> Bool -> IO ()
141 allocaBytes sizeof_termios $ \p_tios -> do
142 throwErrnoIfMinus1Retry "setEcho"
143 (c_tcgetattr (fromIntegral fd) p_tios)
144 c_lflag <- c_lflag p_tios :: IO CTcflag
145 let new_c_lflag | on = c_lflag .|. prel_echo
146 | otherwise = c_lflag .&. complement prel_echo
147 poke_c_lflag p_tios (new_c_lflag :: CTcflag)
148 tcSetAttr fd prel_tcsanow p_tios
150 getEcho :: Int -> IO Bool
152 allocaBytes sizeof_termios $ \p_tios -> do
153 throwErrnoIfMinus1Retry "setEcho"
154 (c_tcgetattr (fromIntegral fd) p_tios)
155 c_lflag <- c_lflag p_tios :: IO CTcflag
156 return ((c_lflag .&. prel_echo) /= 0)
158 setCooked :: Int -> Bool -> IO ()
159 setCooked fd cooked =
160 allocaBytes sizeof_termios $ \p_tios -> do
161 throwErrnoIfMinus1Retry "setCooked"
162 (c_tcgetattr (fromIntegral fd) p_tios)
164 -- turn on/off ICANON
165 c_lflag <- c_lflag p_tios :: IO CTcflag
166 let new_c_lflag | cooked = c_lflag .|. prel_icanon
167 | otherwise = c_lflag .&. complement prel_icanon
168 poke_c_lflag p_tios (new_c_lflag :: CTcflag)
170 -- set VMIN & VTIME to 1/0 respectively
172 c_cc <- prel_ptr_c_cc p_tios
173 let vmin = c_cc `plusPtr` prel_vmin :: Ptr Word8
174 vtime = c_cc `plusPtr` prel_vtime :: Ptr Word8
178 tcSetAttr fd prel_tcsanow p_tios
180 -- tcsetattr() when invoked by a background process causes the process
181 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
182 -- in its terminal flags (try it...). This function provides a
183 -- wrapper which temporarily blocks SIGTTOU around the call, making it
186 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
187 tcSetAttr fd options p_tios = do
188 allocaBytes sizeof_sigset_t $ \ p_sigset -> do
189 allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
190 c_sigemptyset p_sigset
191 c_sigaddset p_sigset prel_sigttou
192 c_sigprocmask prel_sig_block p_sigset p_old_sigset
193 throwErrnoIfMinus1Retry_ "tcSetAttr" $
194 c_tcsetattr (fromIntegral fd) options p_tios
195 c_sigprocmask prel_sig_setmask p_old_sigset nullPtr
197 foreign import ccall "prel_lflag" c_lflag :: Ptr Termios -> IO CTcflag
198 foreign import ccall "prel_poke_lflag" c_lflag :: Ptr Termios -> CTcflag -> IO ()
199 foreign import ccall "prel_ptr_c_cc" ptr_c_cc :: Ptr Termios -> IO Word8
201 foreign import ccall "prel_echo" unsafe prel_echo :: CInt
202 foreign import ccall "prel_tcsanow" unsafe prel_tcsanow :: CInt
203 foreign import ccall "prel_icanon" unsafe prel_icanon :: CInt
204 foreign import ccall "prel_vmin" unsafe prel_vmin :: CInt
205 foreign import ccall "prel_vtime" unsafe prel_vtime :: CInt
206 foreign import ccall "prel_sigttou" unsafe prel_sigttou :: CInt
207 foreign import ccall "prel_sig_block" unsafe prel_sig_block :: CInt
208 foreign import ccall "prel_sig_setmask" unsafe prel_sig_setmask :: CInt
209 foreign import ccall "prel_f_getfl" unsafe prel_f_getfl :: CInt
210 foreign import ccall "prel_f_setfl" unsafe prel_f_setfl :: CInt
213 -- bogus defns for win32
214 setCooked :: Int -> Bool -> IO ()
215 setCooked fd cooked = return ()
217 setEcho :: Int -> Bool -> IO ()
218 setEcho fd on = return ()
220 getEcho :: Int -> IO Bool
221 getEcho fd = return False
225 -- ---------------------------------------------------------------------------
226 -- Turning on non-blocking for a file descriptor
228 #ifndef mingw32_TARGET_OS
230 setNonBlockingFD fd = do
231 flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
232 (fcntl_read (fromIntegral fd) prel_f_getfl)
233 -- An error when setting O_NONBLOCK isn't fatal: on some systems
234 -- there are certain file handles on which this will fail (eg. /dev/null
235 -- on FreeBSD) so we throw away the return code from fcntl_write.
236 fcntl_write (fromIntegral fd) prel_f_setfl (flags .|. o_NONBLOCK)
239 -- bogus defns for win32
240 setNonBlockingFD fd = return ()
244 -- -----------------------------------------------------------------------------
247 foreign import "stat" unsafe
248 c_stat :: CString -> Ptr CStat -> IO CInt
250 foreign import "fstat" unsafe
251 c_fstat :: CInt -> Ptr CStat -> IO CInt
253 foreign import "open" unsafe
254 c_open :: CString -> CInt -> CMode -> IO CInt
256 foreign import ccall "prel_sizeof_stat" unsafe sizeof_stat :: Int
257 foreign import ccall "prel_st_mtime" unsafe st_mtime :: Ptr CStat -> IO CTime
258 foreign import ccall "prel_st_size" unsafe st_size :: Ptr CStat -> IO COff
259 foreign import ccall "prel_st_mode" unsafe st_mode :: Ptr CStat -> IO CMode
261 #ifndef mingw32_TARGET_OS
262 foreign import ccall "prel_sizeof_termios" unsafe sizeof_termios :: Int
263 foreign import ccall "prel_sizeof_sigset_t" unsafe sizeof_sigset_t :: Int
267 foreign import ccall "prel_o_rdonly" unsafe o_RDONLY :: CInt
268 foreign import ccall "prel_o_wronly" unsafe o_WRONLY :: CInt
269 foreign import ccall "prel_o_rdwr" unsafe o_RDWR :: CInt
270 foreign import ccall "prel_o_append" unsafe o_APPEND :: CInt
271 foreign import ccall "prel_o_creat" unsafe o_CREAT :: CInt
272 foreign import ccall "prel_o_excl" unsafe o_EXCL :: CInt
273 foreign import ccall "prel_o_trunc" unsafe o_TRUNC :: CInt
277 foreign import ccall "prel_o_noctty" unsafe o_NOCTTY :: CInt
278 foreign import ccall "prel_o_nonblock" unsafe o_NONBLOCK :: CInt
279 foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt
282 foreign import "isatty" unsafe
283 c_isatty :: CInt -> IO CInt
285 foreign import "close" unsafe
286 c_close :: CInt -> IO CInt
288 #ifdef mingw32_TARGET_OS
289 closeFd :: Bool -> CInt -> IO CInt
291 | isStream = c_closesocket fd
292 | otherwise = c_close fd
294 foreign import "closesocket" unsafe
295 c_closesocket :: CInt -> IO CInt
298 foreign import "lseek" unsafe
299 c_lseek :: CInt -> COff -> CInt -> IO COff
301 #ifndef mingw32_TARGET_OS
302 foreign import "fcntl" unsafe
303 fcntl_read :: CInt -> CInt -> IO CInt
305 foreign import "fcntl" unsafe
306 fcntl_write :: CInt -> CInt -> CInt -> IO CInt
308 foreign import "fork" unsafe
311 foreign import "sigemptyset_PrelPosix_wrap" unsafe
312 c_sigemptyset :: Ptr CSigset -> IO ()
314 foreign import "sigaddset" unsafe
315 c_sigaddset :: Ptr CSigset -> CInt -> IO ()
317 foreign import "sigprocmask" unsafe
318 c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
320 foreign import "tcgetattr" unsafe
321 c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
323 foreign import "tcsetattr" unsafe
324 c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
326 foreign import "unlink" unsafe
327 c_unlink :: CString -> IO CInt
329 foreign import "waitpid" unsafe
330 c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid