1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
2 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
3 {-# OPTIONS_HADDOCK hide #-}
5 -----------------------------------------------------------------------------
7 -- Module : System.Posix.Internals
8 -- Copyright : (c) The University of Glasgow, 1992-2002
9 -- License : see libraries/base/LICENSE
11 -- Maintainer : cvs-ghc@haskell.org
12 -- Stability : internal
13 -- Portability : non-portable (requires POSIX)
15 -- POSIX support layer for the standard libraries.
16 -- This library is built on *every* platform, including Win32.
18 -- Non-posix compliant in order to support the following features:
19 -- * S_ISSOCK (no sockets in POSIX)
21 -----------------------------------------------------------------------------
24 module System
.Posix
.Internals
where
27 # include
"HsBaseConfig.h"
30 #if ! (defined
(mingw32_HOST_OS
) || defined
(__MINGW32__
))
33 import System
.Posix
.Types
41 #if !defined
(HTYPE_TCFLAG_T
)
42 import System
.IO.Error
45 #if __GLASGOW_HASKELL__
51 import Hugs
.Prelude
(IOException
(..), IOErrorType
(..))
52 import Hugs
.IO (IOMode(..))
55 import Control
.Exception
60 {-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
63 -- ---------------------------------------------------------------------------
81 #ifndef __GLASGOW_HASKELL__
85 -- ---------------------------------------------------------------------------
86 -- stat()-related stuff
88 fdFileSize
:: FD
-> IO Integer
90 allocaBytes sizeof_stat
$ \ p_stat
-> do
91 throwErrnoIfMinus1Retry
"fileSize" $
93 c_mode
<- st_mode p_stat
:: IO CMode
94 if not (s_isreg c_mode
)
97 c_size
<- st_size p_stat
98 return (fromIntegral c_size
)
100 data FDType
= Directory | Stream | RegularFile | RawDevice
103 fileType
:: FilePath -> IO FDType
105 allocaBytes sizeof_stat
$ \ p_stat
-> do
106 withCString file
$ \p_file
-> do
107 throwErrnoIfMinus1Retry
"fileType" $
111 -- NOTE: On Win32 platforms, this will only work with file descriptors
112 -- referring to file handles. i.e., it'll fail for socket FDs.
113 fdStat
:: FD
-> IO (FDType
, CDev
, CIno
)
115 allocaBytes sizeof_stat
$ \ p_stat
-> do
116 throwErrnoIfMinus1Retry
"fdType" $
118 ty
<- statGetType p_stat
123 fdType
:: FD
-> IO FDType
124 fdType fd
= do (ty
,_
,_
) <- fdStat fd
; return ty
126 statGetType
:: Ptr CStat
-> IO FDType
127 statGetType p_stat
= do
128 c_mode
<- st_mode p_stat
:: IO CMode
130 _ | s_isdir c_mode
-> return Directory
131 | s_isfifo c_mode || s_issock c_mode || s_ischr c_mode
133 | s_isreg c_mode
-> return RegularFile
134 -- Q: map char devices to RawDevice too?
135 | s_isblk c_mode
-> return RawDevice
136 |
otherwise -> ioError ioe_unknownfiletype
138 ioe_unknownfiletype
:: IOException
140 ioe_unknownfiletype
= IOError Nothing UnsupportedOperation
"fdType"
142 # if __GLASGOW_HASKELL__
147 ioe_unknownfiletype
= UserError
"fdType" "unknown file type"
150 #if __GLASGOW_HASKELL__
&& (defined
(mingw32_HOST_OS
) || defined
(__MINGW32__
))
151 closeFd
:: Bool -> CInt
-> IO CInt
153 | isStream
= c_closesocket fd
154 |
otherwise = c_close fd
156 foreign import stdcall unsafe
"HsBase.h closesocket"
157 c_closesocket
:: CInt
-> IO CInt
160 fdGetMode
:: FD
-> IO IOMode
161 #if defined
(mingw32_HOST_OS
) || defined
(__MINGW32__
)
163 -- We don't have a way of finding out which flags are set on FDs
164 -- on Windows, so make a handle that thinks that anything goes.
168 flags
<- throwErrnoIfMinus1Retry
"fdGetMode"
169 (c_fcntl_read fd const_f_getfl
)
172 wH
= (flags
.&. o_WRONLY
) /= 0
173 aH
= (flags
.&. o_APPEND
) /= 0
174 rwH
= (flags
.&. o_RDWR
) /= 0
177 | wH
&& aH
= AppendMode
179 | rwH
= ReadWriteMode
180 |
otherwise = ReadMode
184 -- ---------------------------------------------------------------------------
185 -- Terminal-related stuff
187 fdIsTTY
:: FD
-> IO Bool
188 fdIsTTY fd
= c_isatty fd
>>= return.toBool
190 #if defined
(HTYPE_TCFLAG_T
)
192 setEcho
:: FD
-> Bool -> IO ()
194 tcSetAttr fd
$ \ p_tios
-> do
195 lflag
<- c_lflag p_tios
:: IO CTcflag
197 | on
= lflag
.|
. fromIntegral const_echo
198 |
otherwise = lflag
.&. complement
(fromIntegral const_echo
)
199 poke_c_lflag p_tios
(new_lflag
:: CTcflag
)
201 getEcho
:: FD
-> IO Bool
203 tcSetAttr fd
$ \ p_tios
-> do
204 lflag
<- c_lflag p_tios
:: IO CTcflag
205 return ((lflag
.&. fromIntegral const_echo
) /= 0)
207 setCooked
:: FD
-> Bool -> IO ()
208 setCooked fd cooked
=
209 tcSetAttr fd
$ \ p_tios
-> do
211 -- turn on/off ICANON
212 lflag
<- c_lflag p_tios
:: IO CTcflag
213 let new_lflag | cooked
= lflag
.|
. (fromIntegral const_icanon
)
214 |
otherwise = lflag
.&. complement
(fromIntegral const_icanon
)
215 poke_c_lflag p_tios
(new_lflag
:: CTcflag
)
217 -- set VMIN & VTIME to 1/0 respectively
218 when (not cooked
) $ do
219 c_cc
<- ptr_c_cc p_tios
220 let vmin
= (c_cc `plusPtr`
(fromIntegral const_vmin
)) :: Ptr Word8
221 vtime
= (c_cc `plusPtr`
(fromIntegral const_vtime
)) :: Ptr Word8
225 tcSetAttr
:: FD
-> (Ptr CTermios
-> IO a
) -> IO a
226 tcSetAttr fd fun
= do
227 allocaBytes sizeof_termios
$ \p_tios
-> do
228 throwErrnoIfMinus1Retry
"tcSetAttr"
229 (c_tcgetattr fd p_tios
)
231 #ifdef __GLASGOW_HASKELL__
232 -- Save a copy of termios, if this is a standard file descriptor.
233 -- These terminal settings are restored in hs_exit().
235 p
<- get_saved_termios fd
236 when (p
== nullPtr
) $ do
237 saved_tios
<- mallocBytes sizeof_termios
238 copyBytes saved_tios p_tios sizeof_termios
239 set_saved_termios fd saved_tios
242 -- tcsetattr() when invoked by a background process causes the process
243 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
244 -- in its terminal flags (try it...). This function provides a
245 -- wrapper which temporarily blocks SIGTTOU around the call, making it
247 allocaBytes sizeof_sigset_t
$ \ p_sigset
-> do
248 allocaBytes sizeof_sigset_t
$ \ p_old_sigset
-> do
249 c_sigemptyset p_sigset
250 c_sigaddset p_sigset const_sigttou
251 c_sigprocmask const_sig_block p_sigset p_old_sigset
252 r
<- fun p_tios
-- do the business
253 throwErrnoIfMinus1Retry_
"tcSetAttr" $
254 c_tcsetattr fd const_tcsanow p_tios
255 c_sigprocmask const_sig_setmask p_old_sigset nullPtr
258 #ifdef __GLASGOW_HASKELL__
259 foreign import ccall unsafe
"HsBase.h __hscore_get_saved_termios"
260 get_saved_termios
:: CInt
-> IO (Ptr CTermios
)
262 foreign import ccall unsafe
"HsBase.h __hscore_set_saved_termios"
263 set_saved_termios
:: CInt
-> (Ptr CTermios
) -> IO ()
268 -- 'raw' mode for Win32 means turn off 'line input' (=> buffering and
269 -- character translation for the console.) The Win32 API for doing
270 -- this is GetConsoleMode(), which also requires echoing to be disabled
271 -- when turning off 'line input' processing. Notice that turning off
272 -- 'line input' implies enter/return is reported as '\r' (and it won't
273 -- report that character until another character is input..odd.) This
274 -- latter feature doesn't sit too well with IO actions like IO.hGetLine..
275 -- consider yourself warned.
276 setCooked
:: FD
-> Bool -> IO ()
277 setCooked fd cooked
= do
278 x
<- set_console_buffering fd
(if cooked
then 1 else 0)
280 then ioError (ioe_unk_error
"setCooked" "failed to set buffering")
283 ioe_unk_error
:: String -> String -> IOException
284 ioe_unk_error loc msg
286 = ioeSetErrorString
(mkIOError OtherError loc Nothing Nothing
) msg
291 -- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
292 -- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
293 setEcho
:: FD
-> Bool -> IO ()
295 x
<- set_console_echo fd
(if on
then 1 else 0)
297 then ioError (ioe_unk_error
"setEcho" "failed to set echoing")
300 getEcho
:: FD
-> IO Bool
302 r
<- get_console_echo fd
304 then ioError (ioe_unk_error
"getEcho" "failed to get echoing")
307 foreign import ccall unsafe
"consUtils.h set_console_buffering__"
308 set_console_buffering
:: CInt
-> CInt
-> IO CInt
310 foreign import ccall unsafe
"consUtils.h set_console_echo__"
311 set_console_echo
:: CInt
-> CInt
-> IO CInt
313 foreign import ccall unsafe
"consUtils.h get_console_echo__"
314 get_console_echo
:: CInt
-> IO CInt
318 -- ---------------------------------------------------------------------------
319 -- Turning on non-blocking for a file descriptor
321 setNonBlockingFD
:: FD
-> IO ()
322 #if !defined
(mingw32_HOST_OS
) && !defined
(__MINGW32__
)
323 setNonBlockingFD fd
= do
324 flags
<- throwErrnoIfMinus1Retry
"setNonBlockingFD"
325 (c_fcntl_read fd const_f_getfl
)
326 -- An error when setting O_NONBLOCK isn't fatal: on some systems
327 -- there are certain file handles on which this will fail (eg. /dev/null
328 -- on FreeBSD) so we throw away the return code from fcntl_write.
329 unless (testBit flags
(fromIntegral o_NONBLOCK
)) $ do
330 c_fcntl_write fd const_f_setfl
(fromIntegral (flags
.|
. o_NONBLOCK
))
334 -- bogus defns for win32
335 setNonBlockingFD _
= return ()
339 -- -----------------------------------------------------------------------------
340 -- Set close-on-exec for a file descriptor
342 setCloseOnExec
:: FD
-> IO ()
343 setCloseOnExec fd
= do
344 throwErrnoIfMinus1
"setCloseOnExec" $
345 c_fcntl_write fd const_f_setfd const_fd_cloexec
348 -- -----------------------------------------------------------------------------
351 foreign import ccall unsafe
"HsBase.h access"
352 c_access
:: CString
-> CInt
-> IO CInt
354 foreign import ccall unsafe
"HsBase.h chmod"
355 c_chmod
:: CString
-> CMode
-> IO CInt
357 foreign import ccall unsafe
"HsBase.h close"
358 c_close
:: CInt
-> IO CInt
360 foreign import ccall unsafe
"HsBase.h closedir"
361 c_closedir
:: Ptr CDir
-> IO CInt
363 foreign import ccall unsafe
"HsBase.h creat"
364 c_creat
:: CString
-> CMode
-> IO CInt
366 foreign import ccall unsafe
"HsBase.h dup"
367 c_dup
:: CInt
-> IO CInt
369 foreign import ccall unsafe
"HsBase.h dup2"
370 c_dup2
:: CInt
-> CInt
-> IO CInt
372 foreign import ccall unsafe
"HsBase.h __hscore_fstat"
373 c_fstat
:: CInt
-> Ptr CStat
-> IO CInt
375 foreign import ccall unsafe
"HsBase.h isatty"
376 c_isatty
:: CInt
-> IO CInt
378 #if defined
(mingw32_HOST_OS
) || defined
(__MINGW32__
)
379 foreign import ccall unsafe
"HsBase.h __hscore_lseek"
380 c_lseek
:: CInt
-> Int64
-> CInt
-> IO Int64
382 foreign import ccall unsafe
"HsBase.h __hscore_lseek"
383 c_lseek
:: CInt
-> COff
-> CInt
-> IO COff
386 foreign import ccall unsafe
"HsBase.h __hscore_lstat"
387 lstat
:: CString
-> Ptr CStat
-> IO CInt
389 foreign import ccall unsafe
"HsBase.h __hscore_open"
390 c_open
:: CString
-> CInt
-> CMode
-> IO CInt
392 foreign import ccall unsafe
"HsBase.h opendir"
393 c_opendir
:: CString
-> IO (Ptr CDir
)
395 foreign import ccall unsafe
"HsBase.h __hscore_mkdir"
396 mkdir
:: CString
-> CInt
-> IO CInt
398 foreign import ccall unsafe
"HsBase.h read"
399 c_read
:: CInt
-> Ptr CChar
-> CSize
-> IO CSsize
401 foreign import ccall unsafe
"HsBase.h rewinddir"
402 c_rewinddir
:: Ptr CDir
-> IO ()
404 foreign import ccall unsafe
"HsBase.h __hscore_stat"
405 c_stat
:: CString
-> Ptr CStat
-> IO CInt
407 foreign import ccall unsafe
"HsBase.h umask"
408 c_umask
:: CMode
-> IO CMode
410 foreign import ccall unsafe
"HsBase.h write"
411 c_write
:: CInt
-> Ptr CChar
-> CSize
-> IO CSsize
413 foreign import ccall unsafe
"HsBase.h __hscore_ftruncate"
414 c_ftruncate
:: CInt
-> COff
-> IO CInt
416 foreign import ccall unsafe
"HsBase.h unlink"
417 c_unlink
:: CString
-> IO CInt
419 foreign import ccall unsafe
"HsBase.h getpid"
422 #if !defined
(mingw32_HOST_OS
) && !defined
(__MINGW32__
)
423 foreign import ccall unsafe
"HsBase.h fcntl"
424 c_fcntl_read
:: CInt
-> CInt
-> IO CInt
426 foreign import ccall unsafe
"HsBase.h fcntl"
427 c_fcntl_write
:: CInt
-> CInt
-> CLong
-> IO CInt
429 foreign import ccall unsafe
"HsBase.h fcntl"
430 c_fcntl_lock
:: CInt
-> CInt
-> Ptr CFLock
-> IO CInt
432 foreign import ccall unsafe
"HsBase.h fork"
435 foreign import ccall unsafe
"HsBase.h link"
436 c_link
:: CString
-> CString
-> IO CInt
438 foreign import ccall unsafe
"HsBase.h mkfifo"
439 c_mkfifo
:: CString
-> CMode
-> IO CInt
441 foreign import ccall unsafe
"HsBase.h pipe"
442 c_pipe
:: Ptr CInt
-> IO CInt
444 foreign import ccall unsafe
"HsBase.h __hscore_sigemptyset"
445 c_sigemptyset
:: Ptr CSigset
-> IO CInt
447 foreign import ccall unsafe
"HsBase.h __hscore_sigaddset"
448 c_sigaddset
:: Ptr CSigset
-> CInt
-> IO CInt
450 foreign import ccall unsafe
"HsBase.h sigprocmask"
451 c_sigprocmask
:: CInt
-> Ptr CSigset
-> Ptr CSigset
-> IO CInt
453 foreign import ccall unsafe
"HsBase.h tcgetattr"
454 c_tcgetattr
:: CInt
-> Ptr CTermios
-> IO CInt
456 foreign import ccall unsafe
"HsBase.h tcsetattr"
457 c_tcsetattr
:: CInt
-> CInt
-> Ptr CTermios
-> IO CInt
459 foreign import ccall unsafe
"HsBase.h utime"
460 c_utime
:: CString
-> Ptr CUtimbuf
-> IO CInt
462 foreign import ccall unsafe
"HsBase.h waitpid"
463 c_waitpid
:: CPid
-> Ptr CInt
-> CInt
-> IO CPid
466 -- traversing directories
467 foreign import ccall unsafe
"dirUtils.h __hscore_readdir"
468 readdir
:: Ptr CDir
-> Ptr
(Ptr CDirent
) -> IO CInt
470 foreign import ccall unsafe
"HsBase.h __hscore_free_dirent"
471 freeDirEnt
:: Ptr CDirent
-> IO ()
473 foreign import ccall unsafe
"HsBase.h __hscore_end_of_dir"
476 foreign import ccall unsafe
"HsBase.h __hscore_d_name"
477 d_name
:: Ptr CDirent
-> IO CString
480 foreign import ccall unsafe
"HsBase.h __hscore_o_rdonly" o_RDONLY
:: CInt
481 foreign import ccall unsafe
"HsBase.h __hscore_o_wronly" o_WRONLY
:: CInt
482 foreign import ccall unsafe
"HsBase.h __hscore_o_rdwr" o_RDWR
:: CInt
483 foreign import ccall unsafe
"HsBase.h __hscore_o_append" o_APPEND
:: CInt
484 foreign import ccall unsafe
"HsBase.h __hscore_o_creat" o_CREAT
:: CInt
485 foreign import ccall unsafe
"HsBase.h __hscore_o_excl" o_EXCL
:: CInt
486 foreign import ccall unsafe
"HsBase.h __hscore_o_trunc" o_TRUNC
:: CInt
489 foreign import ccall unsafe
"HsBase.h __hscore_o_noctty" o_NOCTTY
:: CInt
490 foreign import ccall unsafe
"HsBase.h __hscore_o_nonblock" o_NONBLOCK
:: CInt
491 foreign import ccall unsafe
"HsBase.h __hscore_o_binary" o_BINARY
:: CInt
493 foreign import ccall unsafe
"HsBase.h __hscore_s_isreg" c_s_isreg
:: CMode
-> CInt
494 foreign import ccall unsafe
"HsBase.h __hscore_s_ischr" c_s_ischr
:: CMode
-> CInt
495 foreign import ccall unsafe
"HsBase.h __hscore_s_isblk" c_s_isblk
:: CMode
-> CInt
496 foreign import ccall unsafe
"HsBase.h __hscore_s_isdir" c_s_isdir
:: CMode
-> CInt
497 foreign import ccall unsafe
"HsBase.h __hscore_s_isfifo" c_s_isfifo
:: CMode
-> CInt
499 s_isreg
:: CMode
-> Bool
500 s_isreg cm
= c_s_isreg cm
/= 0
501 s_ischr
:: CMode
-> Bool
502 s_ischr cm
= c_s_ischr cm
/= 0
503 s_isblk
:: CMode
-> Bool
504 s_isblk cm
= c_s_isblk cm
/= 0
505 s_isdir
:: CMode
-> Bool
506 s_isdir cm
= c_s_isdir cm
/= 0
507 s_isfifo
:: CMode
-> Bool
508 s_isfifo cm
= c_s_isfifo cm
/= 0
510 foreign import ccall unsafe
"HsBase.h __hscore_sizeof_stat" sizeof_stat
:: Int
511 foreign import ccall unsafe
"HsBase.h __hscore_st_mtime" st_mtime
:: Ptr CStat
-> IO CTime
512 #ifdef mingw32_HOST_OS
513 foreign import ccall unsafe
"HsBase.h __hscore_st_size" st_size
:: Ptr CStat
-> IO Int64
515 foreign import ccall unsafe
"HsBase.h __hscore_st_size" st_size
:: Ptr CStat
-> IO COff
517 foreign import ccall unsafe
"HsBase.h __hscore_st_mode" st_mode
:: Ptr CStat
-> IO CMode
518 foreign import ccall unsafe
"HsBase.h __hscore_st_dev" st_dev
:: Ptr CStat
-> IO CDev
519 foreign import ccall unsafe
"HsBase.h __hscore_st_ino" st_ino
:: Ptr CStat
-> IO CIno
521 foreign import ccall unsafe
"HsBase.h __hscore_echo" const_echo
:: CInt
522 foreign import ccall unsafe
"HsBase.h __hscore_tcsanow" const_tcsanow
:: CInt
523 foreign import ccall unsafe
"HsBase.h __hscore_icanon" const_icanon
:: CInt
524 foreign import ccall unsafe
"HsBase.h __hscore_vmin" const_vmin
:: CInt
525 foreign import ccall unsafe
"HsBase.h __hscore_vtime" const_vtime
:: CInt
526 foreign import ccall unsafe
"HsBase.h __hscore_sigttou" const_sigttou
:: CInt
527 foreign import ccall unsafe
"HsBase.h __hscore_sig_block" const_sig_block
:: CInt
528 foreign import ccall unsafe
"HsBase.h __hscore_sig_setmask" const_sig_setmask
:: CInt
529 foreign import ccall unsafe
"HsBase.h __hscore_f_getfl" const_f_getfl
:: CInt
530 foreign import ccall unsafe
"HsBase.h __hscore_f_setfl" const_f_setfl
:: CInt
531 foreign import ccall unsafe
"HsBase.h __hscore_f_setfd" const_f_setfd
:: CInt
532 foreign import ccall unsafe
"HsBase.h __hscore_fd_cloexec" const_fd_cloexec
:: CLong
534 #if defined
(HTYPE_TCFLAG_T
)
535 foreign import ccall unsafe
"HsBase.h __hscore_sizeof_termios" sizeof_termios
:: Int
536 foreign import ccall unsafe
"HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t
:: Int
538 foreign import ccall unsafe
"HsBase.h __hscore_lflag" c_lflag
:: Ptr CTermios
-> IO CTcflag
539 foreign import ccall unsafe
"HsBase.h __hscore_poke_lflag" poke_c_lflag
:: Ptr CTermios
-> CTcflag
-> IO ()
540 foreign import ccall unsafe
"HsBase.h __hscore_ptr_c_cc" ptr_c_cc
:: Ptr CTermios
-> IO (Ptr Word8
)
543 s_issock
:: CMode
-> Bool
544 #if !defined
(mingw32_HOST_OS
) && !defined
(__MINGW32__
)
545 s_issock cmode
= c_s_issock cmode
/= 0
546 foreign import ccall unsafe
"HsBase.h __hscore_s_issock" c_s_issock
:: CMode
-> CInt