GHC/Posix.hsc

   1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: Posix.hsc,v 1.1 2001/06/28 14:15:03 simonmar 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 GHC.Posix where
  12
  13 #include "HsCore.h"
  14
  15 import Control.Monad
  16
  17 import Foreign
  18 import Foreign.C
  19
  20 import Data.Bits
  21 import Data.Maybe
  22
  23 import GHC.Base
  24 import GHC.Num
  25 import GHC.Real
  26 import GHC.IOBase
  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
  40 #ifdef mingw32_TARGET_OS
  41 type CSsize  = #type size_t
  42 #else
  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 "fdFileSize" $
  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 fileType :: FilePath -> IO FDType
  73 fileType file =
  74   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  75   withCString file $ \p_file -> do
  76     throwErrnoIfMinus1Retry "fileType" $
  77       c_stat p_file p_stat
  78     statGetType p_stat
  79
  80 fdType :: Int -> IO FDType
  81 fdType fd =
  82   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  83     throwErrnoIfMinus1Retry "fdType" $
  84         c_fstat (fromIntegral fd) p_stat
  85     statGetType p_stat
  86
  87 statGetType p_stat = do
  88   c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
  89   case () of
  90       _ | s_isdir c_mode                     -> return Directory
  91         | s_isfifo c_mode || s_issock c_mode -> return Stream
  92         | s_isreg c_mode                     -> return RegularFile
  93         | otherwise                          -> ioException ioe_unknownfiletype
  94
  95
  96 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
  97                         "unknown file type" Nothing
  98
  99 foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
 100 #def inline int s_isreg_wrap(m) { return S_ISREG(m); }
 101
 102 foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
 103 #def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
 104
 105 foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
 106 #def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
 107
 108 #ifndef mingw32_TARGET_OS
 109 foreign import "s_issock_wrap" s_issock :: CMode -> Bool
 110 #def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
 111 #else
 112 s_issock :: CMode -> Bool
 113 s_issock cmode = False
 114 #endif
 115 -- ---------------------------------------------------------------------------
 116 -- Terminal-related stuff
 117
 118 fdIsTTY :: Int -> IO Bool
 119 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 120
 121 #ifndef mingw32_TARGET_OS
 122
 123 type Termios = ()
 124
 125 setEcho :: Int -> Bool -> IO ()
 126 setEcho fd on = do
 127   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 128     throwErrnoIfMinus1Retry "setEcho"
 129         (c_tcgetattr (fromIntegral fd) p_tios)
 130     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 131     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 132                     | otherwise = c_lflag .&. complement (#const ECHO)
 133     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 134     tcSetAttr fd (#const TCSANOW) p_tios
 135
 136 getEcho :: Int -> IO Bool
 137 getEcho fd = do
 138   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 139     throwErrnoIfMinus1Retry "setEcho"
 140         (c_tcgetattr (fromIntegral fd) p_tios)
 141     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 142     return ((c_lflag .&. (#const ECHO)) /= 0)
 143
 144 setCooked :: Int -> Bool -> IO ()
 145 setCooked fd cooked =
 146   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 147     throwErrnoIfMinus1Retry "setCooked"
 148         (c_tcgetattr (fromIntegral fd) p_tios)
 149
 150     -- turn on/off ICANON
 151     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 152     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 153                     | otherwise = c_lflag .&. complement (#const ICANON)
 154     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 155
 156     -- set VMIN & VTIME to 1/0 respectively
 157     when cooked $ do
 158             let c_cc  = (#ptr struct termios, c_cc) p_tios
 159                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 160                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 161             poke vmin  1
 162             poke vtime 0
 163
 164     tcSetAttr fd (#const TCSANOW) p_tios
 165
 166 -- tcsetattr() when invoked by a background process causes the process
 167 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 168 -- in its terminal flags (try it...).  This function provides a
 169 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 170 -- transparent.
 171
 172 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 173 tcSetAttr fd options p_tios = do
 174   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 175   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 176      c_sigemptyset p_sigset
 177      c_sigaddset   p_sigset (#const SIGTTOU)
 178      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 179      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 180          c_tcsetattr (fromIntegral fd) options p_tios
 181      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 182
 183 #else
 184
 185 -- bogus defns for win32
 186 setCooked :: Int -> Bool -> IO ()
 187 setCooked fd cooked = return ()
 188
 189 setEcho :: Int -> Bool -> IO ()
 190 setEcho fd on = return ()
 191
 192 getEcho :: Int -> IO Bool
 193 getEcho fd = return False
 194
 195 #endif
 196
 197 -- ---------------------------------------------------------------------------
 198 -- Turning on non-blocking for a file descriptor
 199
 200 #ifndef mingw32_TARGET_OS
 201
 202 setNonBlockingFD fd = do
 203   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 204                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 205   throwErrnoIfMinus1Retry "setNonBlockingFD"
 206         (fcntl_write (fromIntegral fd)
 207            (#const F_SETFL) (flags .|. #const O_NONBLOCK))
 208 #else
 209
 210 -- bogus defns for win32
 211 setNonBlockingFD fd = return ()
 212
 213 #endif
 214
 215 -- -----------------------------------------------------------------------------
 216 -- foreign imports
 217
 218 foreign import "stat" unsafe
 219    c_stat :: CString -> Ptr CStat -> IO CInt
 220
 221 foreign import "fstat" unsafe
 222    c_fstat :: CInt -> Ptr CStat -> IO CInt
 223
 224 #ifdef HAVE_LSTAT
 225 foreign import "lstat" unsafe
 226    c_lstat :: CString -> Ptr CStat -> IO CInt
 227 #endif
 228
 229 foreign import "open" unsafe
 230    c_open :: CString -> CInt -> CMode -> IO CInt
 231
 232 -- POSIX flags only:
 233 o_RDONLY    = (#const O_RDONLY)    :: CInt
 234 o_WRONLY    = (#const O_WRONLY)    :: CInt
 235 o_RDWR      = (#const O_RDWR)      :: CInt
 236 o_APPEND    = (#const O_APPEND)    :: CInt
 237 o_CREAT     = (#const O_CREAT)     :: CInt
 238 o_EXCL      = (#const O_EXCL)      :: CInt
 239 o_TRUNC     = (#const O_TRUNC)     :: CInt
 240
 241 #ifdef mingw32_TARGET_OS
 242 o_NOCTTY    = 0 :: CInt
 243 o_NONBLOCK  = 0 :: CInt
 244 #else
 245 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 246 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 247 #endif
 248
 249 #ifdef HAVE_O_BINARY
 250 o_BINARY    = (#const O_BINARY)    :: CInt
 251 #endif
 252
 253 foreign import "isatty" unsafe
 254    c_isatty :: CInt -> IO CInt
 255
 256 foreign import "close" unsafe
 257    c_close :: CInt -> IO CInt
 258
 259 foreign import "lseek" unsafe
 260    c_lseek :: CInt -> COff -> CInt -> IO COff
 261
 262 foreign import "write" unsafe
 263    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 264
 265 foreign import "read" unsafe
 266    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 267
 268 #ifndef mingw32_TARGET_OS
 269 foreign import "fcntl" unsafe
 270    fcntl_read  :: CInt -> CInt -> IO CInt
 271
 272 foreign import "fcntl" unsafe
 273    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 274
 275 foreign import "fork" unsafe
 276    fork :: IO CPid
 277
 278 foreign import "sigemptyset" unsafe
 279    c_sigemptyset :: Ptr CSigset -> IO ()
 280
 281 foreign import "sigaddset" unsafe
 282    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 283
 284 foreign import "sigprocmask" unsafe
 285    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 286
 287 foreign import "tcgetattr" unsafe
 288    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 289
 290 foreign import "tcsetattr" unsafe
 291    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 292
 293 foreign import "waitpid" unsafe
 294    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 295 #endif