PrelPosix.hsc 9.37 KB
Newer Older
1
{-# OPTIONS -fno-implicit-prelude #-}
2
3
4
5
6

-- ---------------------------------------------------------------------------
--
-- 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)
9
10
11

module PrelPosix where

12
13
14
-- See above comment for non-Posixness reasons.
-- #include "PosixSource.h"

rrt's avatar
rrt committed
15
#include "HsStd.h"
16

17
18
19
20
import PrelBase
import PrelNum
import PrelReal
import PrelMaybe
21
22
23
24
25
26
27
28
29
30
31
32
import PrelCString
import PrelPtr
import PrelWord
import PrelInt
import PrelCTypesISO
import PrelCTypes
import PrelCError
import PrelStorable
import PrelMarshalAlloc
import PrelMarshalUtils
import PrelBits
import PrelIOBase
33
import Monad
34
35
36
37
38
39
40
41
42
43
44
45
46


-- ---------------------------------------------------------------------------
-- Types

data CDir    = CDir
type CSigset = ()

type CDev    = #type dev_t
type CIno    = #type ino_t
type CMode   = #type mode_t
type COff    = #type off_t
type CPid    = #type pid_t
47
48
49
50

#ifdef mingw32_TARGET_OS
type CSsize  = #type size_t
#else
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
type CGid    = #type gid_t
type CNlink  = #type nlink_t
type CSsize  = #type ssize_t
type CUid    = #type uid_t
type CCc     = #type cc_t
type CSpeed  = #type speed_t
type CTcflag = #type tcflag_t
#endif

-- ---------------------------------------------------------------------------
-- stat()-related stuff

type CStat = ()

fdFileSize :: Int -> IO Integer
fdFileSize fd = 
  allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
    throwErrnoIfMinus1Retry "fileSize" $
	c_fstat (fromIntegral fd) p_stat
    c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode 
    if not (s_isreg c_mode)
	then return (-1)
	else do
    c_size <- (#peek struct stat, st_size) p_stat :: IO COff
    return (fromIntegral c_size)

data FDType  = Directory | Stream | RegularFile
	       deriving (Eq)

sof's avatar
sof committed
80
81
-- NOTE: On Win32 platforms, this will only work with file descriptors
-- referring to file handles. i.e., it'll fail for socket FDs.
82
83
84
fdType :: Int -> IO FDType
fdType fd = 
  allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
sof's avatar
sof committed
85
    throwErrnoIfMinus1Retry "fdType" $
86
87
88
89
90
	c_fstat (fromIntegral fd) p_stat
    c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
    case () of
      _ | s_isdir c_mode 	 	     -> return Directory
        | s_isfifo c_mode || s_issock c_mode -> return Stream
sof's avatar
sof committed
91
92
        | s_isreg c_mode 		     -> return RegularFile
        | otherwise			     -> ioException ioe_unknownfiletype
93
94
95
96

ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
			"unknown file type" Nothing

97
98
foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
#def inline int s_isreg_PrelPosix_wrap(m) { return S_ISREG(m); }
99

100
101
foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
#def inline int s_isdir_PrelPosix_wrap(m) { return S_ISDIR(m); }
102

103
104
foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
#def inline int s_isfifo_PrelPosix_wrap(m) { return S_ISFIFO(m); }
105

106
#ifndef mingw32_TARGET_OS
107
108
foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
#def inline int s_issock_PrelPosix_wrap(m) { return S_ISSOCK(m); }
109
110
111
112
#else
s_issock :: CMode -> Bool
s_issock cmode = False
#endif
113
114
115
116
117
118
119
120
121
122
123
124
125

-- It isn't clear whether ftruncate is POSIX or not (I've read several
-- manpages and they seem to conflict), so we truncate using open/2.
fileTruncate :: FilePath -> IO ()
fileTruncate file = do
  let flags = o_WRONLY .|. o_TRUNC
  withCString file $ \file_cstr -> do
    fd <- fromIntegral `liftM`
	    throwErrnoIfMinus1Retry "fileTruncate"
 	        (c_open file_cstr (fromIntegral flags) 0o666)
    c_close fd
  return ()

126
127
128
129
130
131
-- ---------------------------------------------------------------------------
-- Terminal-related stuff

fdIsTTY :: Int -> IO Bool
fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool

132
133
#ifndef mingw32_TARGET_OS

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
type Termios = ()

setEcho :: Int -> Bool -> IO ()
setEcho fd on = do
  allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
    throwErrnoIfMinus1Retry "setEcho"
	(c_tcgetattr (fromIntegral fd) p_tios)
    c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
    let new_c_lflag | on        = c_lflag .|. (#const ECHO)
	            | otherwise = c_lflag .&. complement (#const ECHO)
    (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
    tcSetAttr fd (#const TCSANOW) p_tios

getEcho :: Int -> IO Bool
getEcho fd = do
  allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
    throwErrnoIfMinus1Retry "setEcho"
	(c_tcgetattr (fromIntegral fd) p_tios)
    c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
    return ((c_lflag .&. (#const ECHO)) /= 0)

setCooked :: Int -> Bool -> IO ()
setCooked fd cooked = 
  allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
    throwErrnoIfMinus1Retry "setCooked"
	(c_tcgetattr (fromIntegral fd) p_tios)

    -- turn on/off ICANON
    c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
    let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
	            | otherwise = c_lflag .&. complement (#const ICANON)
    (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)

    -- set VMIN & VTIME to 1/0 respectively
168
    when cooked $ do
169
170
	    let c_cc  = (#ptr struct termios, c_cc) p_tios
		vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
171
172
173
		vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
	    poke vmin  1
	    poke vtime 0
174

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
    tcSetAttr fd (#const TCSANOW) p_tios

-- tcsetattr() when invoked by a background process causes the process
-- to be sent SIGTTOU regardless of whether the process has TOSTOP set
-- in its terminal flags (try it...).  This function provides a
-- wrapper which temporarily blocks SIGTTOU around the call, making it
-- transparent.

tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
tcSetAttr fd options p_tios = do
  allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
  allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
     c_sigemptyset p_sigset
     c_sigaddset   p_sigset (#const SIGTTOU)
     c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
     throwErrnoIfMinus1Retry_ "tcSetAttr" $
	 c_tcsetattr (fromIntegral fd) options p_tios
     c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr

194
195
196
197
198
199
200
201
202
203
204
205
206
207
#else

-- bogus defns for win32
setCooked :: Int -> Bool -> IO ()
setCooked fd cooked = return ()

setEcho :: Int -> Bool -> IO ()
setEcho fd on = return ()

getEcho :: Int -> IO Bool
getEcho fd = return False

#endif

208
209
210
-- ---------------------------------------------------------------------------
-- Turning on non-blocking for a file descriptor

211
212
#ifndef mingw32_TARGET_OS

213
214
215
setNonBlockingFD fd = do
  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
		 (fcntl_read (fromIntegral fd) (#const F_GETFL))
216
217
218
219
220
  -- An error when setting O_NONBLOCK isn't fatal: on some systems 
  -- there are certain file handles on which this will fail (eg. /dev/null
  -- on FreeBSD) so we throw away the return code from fcntl_write.
  fcntl_write (fromIntegral fd) 
	(#const F_SETFL) (flags .|. #const O_NONBLOCK)
221
222
223
224
225
226
#else

-- bogus defns for win32
setNonBlockingFD fd = return ()

#endif
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252

-- -----------------------------------------------------------------------------
-- foreign imports

foreign import "stat" unsafe
   c_stat :: CString -> Ptr CStat -> IO CInt

foreign import "fstat" unsafe
   c_fstat :: CInt -> Ptr CStat -> IO CInt

#ifdef HAVE_LSTAT
foreign import "lstat" unsafe
   c_lstat :: CString -> Ptr CStat -> IO CInt
#endif

foreign import "open" unsafe
   c_open :: CString -> CInt -> CMode -> IO CInt

-- POSIX flags only:
o_RDONLY    = (#const O_RDONLY)	   :: CInt
o_WRONLY    = (#const O_WRONLY)	   :: CInt
o_RDWR      = (#const O_RDWR)	   :: CInt
o_APPEND    = (#const O_APPEND)	   :: CInt
o_CREAT     = (#const O_CREAT)	   :: CInt
o_EXCL	    = (#const O_EXCL)	   :: CInt
o_TRUNC     = (#const O_TRUNC)	   :: CInt
253
254
255
256
257
258

#ifdef mingw32_TARGET_OS
o_NOCTTY    = 0 :: CInt
o_NONBLOCK  = 0 :: CInt
#else
o_NOCTTY    = (#const O_NOCTTY)	   :: CInt
259
o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
260
261
262
263
264
265
266
267
#endif

#ifdef HAVE_O_BINARY
o_BINARY    = (#const O_BINARY)	   :: CInt
#endif

foreign import "isatty" unsafe
   c_isatty :: CInt -> IO CInt
268
269
270
271

foreign import "close" unsafe
   c_close :: CInt -> IO CInt

sof's avatar
sof committed
272
273
274
275
276
277
278
279
280
281
#ifdef mingw32_TARGET_OS
closeFd :: Bool -> CInt -> IO CInt
closeFd isStream fd 
  | isStream  = c_closesocket fd
  | otherwise = c_close fd

foreign import "closesocket" unsafe
   c_closesocket :: CInt -> IO CInt
#endif

282
283
284
285
286
287
foreign import "lseek" unsafe
   c_lseek :: CInt -> COff -> CInt -> IO COff

foreign import "write" unsafe 
   c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize

288
289
290
foreign import "read" unsafe 
   c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize

291
#ifndef mingw32_TARGET_OS
292
293
294
295
296
297
298
299
300
foreign import "fcntl" unsafe
   fcntl_read  :: CInt -> CInt -> IO CInt

foreign import "fcntl" unsafe
   fcntl_write :: CInt -> CInt -> CInt -> IO CInt

foreign import "fork" unsafe
   fork :: IO CPid 

301
foreign import "sigemptyset_PrelPosix_wrap" unsafe
302
   c_sigemptyset :: Ptr CSigset -> IO ()
303
#def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); }
304
305
306
307
308
309
310
311
312
313
314
315
316

foreign import "sigaddset" unsafe
   c_sigaddset :: Ptr CSigset -> CInt -> IO ()

foreign import "sigprocmask" unsafe
   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()

foreign import "tcgetattr" unsafe
   c_tcgetattr :: CInt -> Ptr Termios -> IO CInt

foreign import "tcsetattr" unsafe
   c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt

317
318
319
foreign import "unlink" unsafe 
   c_unlink :: CString -> IO CInt

320
321
foreign import "waitpid" unsafe
   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
322
#endif