ghc/lib/std/PrelPosix.hsc

   1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: PrelPosix.hsc,v 1.7 2001/06/22 12:36:34 rrt Exp $
   5 --
   6 -- POSIX support layer for the standard libraries
   7 --
   8 -- NON_POSIX_SOURCE needed for the following features:
   9 --      * S_ISSOCK (no sockets in POSIX)
  10
  11 module PrelPosix where
  12
  13 #include "cbits/HsStd.h"
  14
  15 import PrelBase
  16 import PrelNum
  17 import PrelReal
  18 import PrelMaybe
  19 import PrelCString
  20 import PrelPtr
  21 import PrelWord
  22 import PrelInt
  23 import PrelCTypesISO
  24 import PrelCTypes
  25 import PrelCError
  26 import PrelStorable
  27 import PrelMarshalAlloc
  28 import PrelMarshalUtils
  29 import PrelBits
  30 import PrelIOBase
  31 import Monad
  32
  33
  34 -- ---------------------------------------------------------------------------
  35 -- Types
  36
  37 data CDir    = CDir
  38 type CSigset = ()
  39
  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
  45
  46 #ifdef mingw32_TARGET_OS
  47 type CSsize  = #type size_t
  48 #else
  49 type CGid    = #type gid_t
  50 type CNlink  = #type nlink_t
  51 type CSsize  = #type ssize_t
  52 type CUid    = #type uid_t
  53 type CCc     = #type cc_t
  54 type CSpeed  = #type speed_t
  55 type CTcflag = #type tcflag_t
  56 #endif
  57
  58 -- ---------------------------------------------------------------------------
  59 -- stat()-related stuff
  60
  61 type CStat = ()
  62
  63 fdFileSize :: Int -> IO Integer
  64 fdFileSize fd =
  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)
  70         then return (-1)
  71         else do
  72     c_size <- (#peek struct stat, st_size) p_stat :: IO COff
  73     return (fromIntegral c_size)
  74
  75 data FDType  = Directory | Stream | RegularFile
  76                deriving (Eq)
  77
  78 fdType :: Int -> IO FDType
  79 fdType fd =
  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
  84     case () of
  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
  89
  90 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
  91                         "unknown file type" Nothing
  92
  93 foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
  94 #def inline int s_isreg_wrap(m) { return S_ISREG(m); }
  95
  96 foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
  97 #def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
  98
  99 foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
 100 #def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
 101
 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); }
 105 #else
 106 s_issock :: CMode -> Bool
 107 s_issock cmode = False
 108 #endif
 109 -- ---------------------------------------------------------------------------
 110 -- Terminal-related stuff
 111
 112 fdIsTTY :: Int -> IO Bool
 113 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 114
 115 #ifndef mingw32_TARGET_OS
 116
 117 type Termios = ()
 118
 119 setEcho :: Int -> Bool -> IO ()
 120 setEcho fd on = do
 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
 129
 130 getEcho :: Int -> IO Bool
 131 getEcho fd = do
 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)
 137
 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)
 143
 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)
 149
 150     -- set VMIN & VTIME to 1/0 respectively
 151     when cooked $ do
 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
 155             poke vmin  1
 156             poke vtime 0
 157
 158     tcSetAttr fd (#const TCSANOW) p_tios
 159
 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
 164 -- transparent.
 165
 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
 176
 177 #else
 178
 179 -- bogus defns for win32
 180 setCooked :: Int -> Bool -> IO ()
 181 setCooked fd cooked = return ()
 182
 183 setEcho :: Int -> Bool -> IO ()
 184 setEcho fd on = return ()
 185
 186 getEcho :: Int -> IO Bool
 187 getEcho fd = return False
 188
 189 #endif
 190
 191 -- ---------------------------------------------------------------------------
 192 -- Turning on non-blocking for a file descriptor
 193
 194 #ifndef mingw32_TARGET_OS
 195
 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))
 202 #else
 203
 204 -- bogus defns for win32
 205 setNonBlockingFD fd = return ()
 206
 207 #endif
 208
 209 -- -----------------------------------------------------------------------------
 210 -- foreign imports
 211
 212 foreign import "stat" unsafe
 213    c_stat :: CString -> Ptr CStat -> IO CInt
 214
 215 foreign import "fstat" unsafe
 216    c_fstat :: CInt -> Ptr CStat -> IO CInt
 217
 218 #ifdef HAVE_LSTAT
 219 foreign import "lstat" unsafe
 220    c_lstat :: CString -> Ptr CStat -> IO CInt
 221 #endif
 222
 223 foreign import "open" unsafe
 224    c_open :: CString -> CInt -> CMode -> IO CInt
 225
 226 -- POSIX flags only:
 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
 234
 235 #ifdef mingw32_TARGET_OS
 236 o_NOCTTY    = 0 :: CInt
 237 o_NONBLOCK  = 0 :: CInt
 238 #else
 239 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 240 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 241 #endif
 242
 243 #ifdef HAVE_O_BINARY
 244 o_BINARY    = (#const O_BINARY)    :: CInt
 245 #endif
 246
 247 foreign import "isatty" unsafe
 248    c_isatty :: CInt -> IO CInt
 249
 250 foreign import "close" unsafe
 251    c_close :: CInt -> IO CInt
 252
 253 foreign import "lseek" unsafe
 254    c_lseek :: CInt -> COff -> CInt -> IO COff
 255
 256 foreign import "write" unsafe
 257    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 258
 259 foreign import "read" unsafe
 260    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 261
 262 #ifndef mingw32_TARGET_OS
 263 foreign import "fcntl" unsafe
 264    fcntl_read  :: CInt -> CInt -> IO CInt
 265
 266 foreign import "fcntl" unsafe
 267    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 268
 269 foreign import "fork" unsafe
 270    fork :: IO CPid
 271
 272 foreign import "sigemptyset" unsafe
 273    c_sigemptyset :: Ptr CSigset -> IO ()
 274
 275 foreign import "sigaddset" unsafe
 276    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 277
 278 foreign import "sigprocmask" unsafe
 279    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 280
 281 foreign import "tcgetattr" unsafe
 282    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 283
 284 foreign import "tcsetattr" unsafe
 285    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 286
 287 foreign import "waitpid" unsafe
 288    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 289 #endif