GHC/Posix.hsc

   1 {-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: Posix.hsc,v 1.2 2001/07/31 12:48:13 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 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 117 -- manpages and they seem to conflict), so we truncate using open/2.
 118 fileTruncate :: FilePath -> IO ()
 119 fileTruncate file = do
 120   let flags = o_WRONLY .|. o_TRUNC
 121   withCString file $ \file_cstr -> do
 122     fd <- fromIntegral `liftM`
 123             throwErrnoIfMinus1Retry "fileTruncate"
 124                 (c_open file_cstr (fromIntegral flags) 0o666)
 125     c_close fd
 126   return ()
 127
 128 -- ---------------------------------------------------------------------------
 129 -- Terminal-related stuff
 130
 131 fdIsTTY :: Int -> IO Bool
 132 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 133
 134 #ifndef mingw32_TARGET_OS
 135
 136 type Termios = ()
 137
 138 setEcho :: Int -> Bool -> IO ()
 139 setEcho fd on = do
 140   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 141     throwErrnoIfMinus1Retry "setEcho"
 142         (c_tcgetattr (fromIntegral fd) p_tios)
 143     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 144     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 145                     | otherwise = c_lflag .&. complement (#const ECHO)
 146     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 147     tcSetAttr fd (#const TCSANOW) p_tios
 148
 149 getEcho :: Int -> IO Bool
 150 getEcho fd = do
 151   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 152     throwErrnoIfMinus1Retry "setEcho"
 153         (c_tcgetattr (fromIntegral fd) p_tios)
 154     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 155     return ((c_lflag .&. (#const ECHO)) /= 0)
 156
 157 setCooked :: Int -> Bool -> IO ()
 158 setCooked fd cooked =
 159   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 160     throwErrnoIfMinus1Retry "setCooked"
 161         (c_tcgetattr (fromIntegral fd) p_tios)
 162
 163     -- turn on/off ICANON
 164     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 165     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 166                     | otherwise = c_lflag .&. complement (#const ICANON)
 167     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 168
 169     -- set VMIN & VTIME to 1/0 respectively
 170     when cooked $ do
 171             let c_cc  = (#ptr struct termios, c_cc) p_tios
 172                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 173                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 174             poke vmin  1
 175             poke vtime 0
 176
 177     tcSetAttr fd (#const TCSANOW) p_tios
 178
 179 -- tcsetattr() when invoked by a background process causes the process
 180 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 181 -- in its terminal flags (try it...).  This function provides a
 182 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 183 -- transparent.
 184
 185 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 186 tcSetAttr fd options p_tios = do
 187   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 188   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 189      c_sigemptyset p_sigset
 190      c_sigaddset   p_sigset (#const SIGTTOU)
 191      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 192      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 193          c_tcsetattr (fromIntegral fd) options p_tios
 194      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 195
 196 #else
 197
 198 -- bogus defns for win32
 199 setCooked :: Int -> Bool -> IO ()
 200 setCooked fd cooked = return ()
 201
 202 setEcho :: Int -> Bool -> IO ()
 203 setEcho fd on = return ()
 204
 205 getEcho :: Int -> IO Bool
 206 getEcho fd = return False
 207
 208 #endif
 209
 210 -- ---------------------------------------------------------------------------
 211 -- Turning on non-blocking for a file descriptor
 212
 213 #ifndef mingw32_TARGET_OS
 214
 215 setNonBlockingFD fd = do
 216   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 217                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 218   throwErrnoIfMinus1Retry "setNonBlockingFD"
 219         (fcntl_write (fromIntegral fd)
 220            (#const F_SETFL) (flags .|. #const O_NONBLOCK))
 221 #else
 222
 223 -- bogus defns for win32
 224 setNonBlockingFD fd = return ()
 225
 226 #endif
 227
 228 -- -----------------------------------------------------------------------------
 229 -- foreign imports
 230
 231 foreign import "stat" unsafe
 232    c_stat :: CString -> Ptr CStat -> IO CInt
 233
 234 foreign import "fstat" unsafe
 235    c_fstat :: CInt -> Ptr CStat -> IO CInt
 236
 237 #ifdef HAVE_LSTAT
 238 foreign import "lstat" unsafe
 239    c_lstat :: CString -> Ptr CStat -> IO CInt
 240 #endif
 241
 242 foreign import "open" unsafe
 243    c_open :: CString -> CInt -> CMode -> IO CInt
 244
 245 -- POSIX flags only:
 246 o_RDONLY    = (#const O_RDONLY)    :: CInt
 247 o_WRONLY    = (#const O_WRONLY)    :: CInt
 248 o_RDWR      = (#const O_RDWR)      :: CInt
 249 o_APPEND    = (#const O_APPEND)    :: CInt
 250 o_CREAT     = (#const O_CREAT)     :: CInt
 251 o_EXCL      = (#const O_EXCL)      :: CInt
 252 o_TRUNC     = (#const O_TRUNC)     :: CInt
 253
 254 #ifdef mingw32_TARGET_OS
 255 o_NOCTTY    = 0 :: CInt
 256 o_NONBLOCK  = 0 :: CInt
 257 #else
 258 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 259 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 260 #endif
 261
 262 #ifdef HAVE_O_BINARY
 263 o_BINARY    = (#const O_BINARY)    :: CInt
 264 #endif
 265
 266 foreign import "isatty" unsafe
 267    c_isatty :: CInt -> IO CInt
 268
 269 foreign import "close" unsafe
 270    c_close :: CInt -> IO CInt
 271
 272 foreign import "lseek" unsafe
 273    c_lseek :: CInt -> COff -> CInt -> IO COff
 274
 275 foreign import "write" unsafe
 276    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 277
 278 foreign import "read" unsafe
 279    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 280
 281 #ifndef mingw32_TARGET_OS
 282 foreign import "fcntl" unsafe
 283    fcntl_read  :: CInt -> CInt -> IO CInt
 284
 285 foreign import "fcntl" unsafe
 286    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 287
 288 foreign import "fork" unsafe
 289    fork :: IO CPid
 290
 291 foreign import "sigemptyset" unsafe
 292    c_sigemptyset :: Ptr CSigset -> IO ()
 293
 294 foreign import "sigaddset" unsafe
 295    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 296
 297 foreign import "sigprocmask" unsafe
 298    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 299
 300 foreign import "tcgetattr" unsafe
 301    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 302
 303 foreign import "tcsetattr" unsafe
 304    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 305
 306 foreign import "unlink" unsafe
 307    c_unlink :: CString -> IO CInt
 308
 309 foreign import "waitpid" unsafe
 310    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 311 #endif