ghc/lib/std/PrelPosix.hsc

   1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: PrelPosix.hsc,v 1.2 2001/05/18 18:27:20 qrczak Exp $
   5 --
   6 -- POSIX support layer for the standard libraries
   7 --
   8
   9 module PrelPosix where
  10
  11 #include "HsStd.h"
  12
  13 import PrelBase
  14 import PrelNum
  15 import PrelReal
  16 import PrelMaybe
  17 import PrelCString
  18 import PrelPtr
  19 import PrelWord
  20 import PrelInt
  21 import PrelCTypesISO
  22 import PrelCTypes
  23 import PrelCError
  24 import PrelStorable
  25 import PrelMarshalAlloc
  26 import PrelMarshalUtils
  27 import PrelBits
  28 import PrelIOBase
  29
  30
  31 -- ---------------------------------------------------------------------------
  32 -- Types
  33
  34 data CDir    = CDir
  35 type CSigset = ()
  36
  37 type CDev    = #type dev_t
  38 type CIno    = #type ino_t
  39 type CMode   = #type mode_t
  40 type COff    = #type off_t
  41 type CPid    = #type pid_t
  42 #ifndef mingw32_TARGET_OS
  43 type CGid    = #type gid_t
  44 type CNlink  = #type nlink_t
  45 type CSsize  = #type ssize_t
  46 type CUid    = #type uid_t
  47 type CCc     = #type cc_t
  48 type CSpeed  = #type speed_t
  49 type CTcflag = #type tcflag_t
  50 #endif
  51
  52 -- ---------------------------------------------------------------------------
  53 -- stat()-related stuff
  54
  55 type CStat = ()
  56
  57 fdFileSize :: Int -> IO Integer
  58 fdFileSize fd =
  59   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  60     throwErrnoIfMinus1Retry "fileSize" $
  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)
  64         then return (-1)
  65         else do
  66     c_size <- (#peek struct stat, st_size) p_stat :: IO COff
  67     return (fromIntegral c_size)
  68
  69 data FDType  = Directory | Stream | RegularFile
  70                deriving (Eq)
  71
  72 fdType :: Int -> IO FDType
  73 fdType fd =
  74   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  75     throwErrnoIfMinus1Retry "fileSize" $
  76         c_fstat (fromIntegral fd) p_stat
  77     c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
  78     case () of
  79       _ | s_isdir c_mode                     -> return Directory
  80         | s_isfifo c_mode || s_issock c_mode -> return Stream
  81         | s_isreg c_mode                     -> return RegularFile
  82         | otherwise                          -> ioException ioe_unknownfiletype
  83
  84 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
  85                         "unknown file type" Nothing
  86
  87 foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
  88 #def inline int s_isreg_wrap(m) { return S_ISREG(m); }
  89
  90 foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
  91 #def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
  92
  93 foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
  94 #def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
  95
  96 foreign import "s_issock_wrap" s_issock :: CMode -> Bool
  97 #def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
  98
  99 -- ---------------------------------------------------------------------------
 100 -- Terminal-related stuff
 101
 102 fdIsTTY :: Int -> IO Bool
 103 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 104
 105 type Termios = ()
 106
 107 setEcho :: Int -> Bool -> IO ()
 108 setEcho fd on = do
 109   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 110     throwErrnoIfMinus1Retry "setEcho"
 111         (c_tcgetattr (fromIntegral fd) p_tios)
 112     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 113     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 114                     | otherwise = c_lflag .&. complement (#const ECHO)
 115     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 116     tcSetAttr fd (#const TCSANOW) p_tios
 117
 118 getEcho :: Int -> IO Bool
 119 getEcho fd = do
 120   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 121     throwErrnoIfMinus1Retry "setEcho"
 122         (c_tcgetattr (fromIntegral fd) p_tios)
 123     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 124     return ((c_lflag .&. (#const ECHO)) /= 0)
 125
 126 setCooked :: Int -> Bool -> IO ()
 127 setCooked fd cooked =
 128   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 129     throwErrnoIfMinus1Retry "setCooked"
 130         (c_tcgetattr (fromIntegral fd) p_tios)
 131
 132     -- turn on/off ICANON
 133     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 134     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 135                     | otherwise = c_lflag .&. complement (#const ICANON)
 136     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 137
 138     -- set VMIN & VTIME to 1/0 respectively
 139     if cooked
 140         then do
 141             let c_cc  = (#ptr struct termios, c_cc) p_tios
 142                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 143                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 144             poke vmin  1
 145             poke vtime 0
 146         else return ()
 147
 148     tcSetAttr fd (#const TCSANOW) p_tios
 149
 150 -- tcsetattr() when invoked by a background process causes the process
 151 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 152 -- in its terminal flags (try it...).  This function provides a
 153 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 154 -- transparent.
 155
 156 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 157 tcSetAttr fd options p_tios = do
 158   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 159   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 160      c_sigemptyset p_sigset
 161      c_sigaddset   p_sigset (#const SIGTTOU)
 162      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 163      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 164          c_tcsetattr (fromIntegral fd) options p_tios
 165      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 166
 167 -- ---------------------------------------------------------------------------
 168 -- Turning on non-blocking for a file descriptor
 169
 170 setNonBlockingFD fd = do
 171   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 172                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 173   throwErrnoIfMinus1Retry "setNonBlockingFD"
 174         (fcntl_write (fromIntegral fd)
 175            (#const F_SETFL) (flags .|. #const O_NONBLOCK))
 176
 177 -- -----------------------------------------------------------------------------
 178 -- foreign imports
 179
 180 foreign import "stat" unsafe
 181    c_stat :: CString -> Ptr CStat -> IO CInt
 182
 183 foreign import "fstat" unsafe
 184    c_fstat :: CInt -> Ptr CStat -> IO CInt
 185
 186 #ifdef HAVE_LSTAT
 187 foreign import "lstat" unsafe
 188    c_lstat :: CString -> Ptr CStat -> IO CInt
 189 #endif
 190
 191 foreign import "open" unsafe
 192    c_open :: CString -> CInt -> CMode -> IO CInt
 193
 194 -- POSIX flags only:
 195 o_RDONLY    = (#const O_RDONLY)    :: CInt
 196 o_WRONLY    = (#const O_WRONLY)    :: CInt
 197 o_RDWR      = (#const O_RDWR)      :: CInt
 198 o_APPEND    = (#const O_APPEND)    :: CInt
 199 o_CREAT     = (#const O_CREAT)     :: CInt
 200 o_EXCL      = (#const O_EXCL)      :: CInt
 201 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 202 o_TRUNC     = (#const O_TRUNC)     :: CInt
 203 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 204
 205 foreign import "close" unsafe
 206    c_close :: CInt -> IO CInt
 207
 208 foreign import "fcntl" unsafe
 209    fcntl_read  :: CInt -> CInt -> IO CInt
 210
 211 foreign import "fcntl" unsafe
 212    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 213
 214 foreign import "fork" unsafe
 215    fork :: IO CPid
 216
 217 foreign import "isatty" unsafe
 218    c_isatty :: CInt -> IO CInt
 219
 220 foreign import "lseek" unsafe
 221    c_lseek :: CInt -> COff -> CInt -> IO COff
 222
 223 foreign import "read" unsafe
 224    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 225
 226 foreign import "sigemptyset" unsafe
 227    c_sigemptyset :: Ptr CSigset -> IO ()
 228
 229 foreign import "sigaddset" unsafe
 230    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 231
 232 foreign import "sigprocmask" unsafe
 233    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 234
 235 foreign import "tcgetattr" unsafe
 236    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 237
 238 foreign import "tcsetattr" unsafe
 239    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 240
 241 foreign import "waitpid" unsafe
 242    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 243
 244 foreign import "write" unsafe
 245    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 246