ghc/lib/std/PrelPosix.hsc

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