ghc/lib/std/PrelPosix.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: PrelPosix.hsc,v 1.14 2001/09/26 10:35:41 simonmar Exp $
   5 --
   6 -- POSIX support layer for the standard libraries
   7 --
   8 -- Non-posix compliant in order to support the following features:
   9 --      * S_ISSOCK (no sockets in POSIX)
  10
  11 module PrelPosix where
  12
  13 -- See above comment for non-Posixness reasons.
  14 -- #include "PosixSource.h"
  15
  16 #include "HsStd.h"
  17
  18 import PrelBase
  19 import PrelNum
  20 import PrelReal
  21 import PrelMaybe
  22 import PrelCString
  23 import PrelPtr
  24 import PrelWord
  25 import PrelInt
  26 import PrelCTypesISO
  27 import PrelCTypes
  28 import PrelCError
  29 import PrelStorable
  30 import PrelMarshalAlloc
  31 import PrelMarshalUtils
  32 import PrelBits
  33 import PrelIOBase
  34 import Monad
  35
  36
  37 -- ---------------------------------------------------------------------------
  38 -- Types
  39
  40 data CDir    = CDir
  41 type CSigset = ()
  42
  43 type CDev    = #type dev_t
  44 type CIno    = #type ino_t
  45 type CMode   = #type mode_t
  46 type COff    = #type off_t
  47 type CPid    = #type pid_t
  48
  49 #ifdef mingw32_TARGET_OS
  50 type CSsize  = #type size_t
  51 #else
  52 type CGid    = #type gid_t
  53 type CNlink  = #type nlink_t
  54 type CSsize  = #type ssize_t
  55 type CUid    = #type uid_t
  56 type CCc     = #type cc_t
  57 type CSpeed  = #type speed_t
  58 type CTcflag = #type tcflag_t
  59 #endif
  60
  61 -- ---------------------------------------------------------------------------
  62 -- stat()-related stuff
  63
  64 type CStat = ()
  65
  66 fdFileSize :: Int -> IO Integer
  67 fdFileSize fd =
  68   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  69     throwErrnoIfMinus1Retry "fileSize" $
  70         c_fstat (fromIntegral fd) p_stat
  71     c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
  72     if not (s_isreg c_mode)
  73         then return (-1)
  74         else do
  75     c_size <- (#peek struct stat, st_size) p_stat :: IO COff
  76     return (fromIntegral c_size)
  77
  78 data FDType  = Directory | Stream | RegularFile
  79                deriving (Eq)
  80
  81 fdType :: Int -> IO FDType
  82 fdType fd =
  83   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  84     throwErrnoIfMinus1Retry "fileSize" $
  85         c_fstat (fromIntegral fd) p_stat
  86     c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
  87     case () of
  88       _ | s_isdir c_mode                     -> return Directory
  89         | s_isfifo c_mode || s_issock c_mode -> return Stream
  90         | s_isreg c_mode                     -> return RegularFile
  91         | otherwise                          -> ioException ioe_unknownfiletype
  92
  93 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
  94                         "unknown file type" Nothing
  95
  96 foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
  97 #def inline int s_isreg_PrelPosix_wrap(m) { return S_ISREG(m); }
  98
  99 foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
 100 #def inline int s_isdir_PrelPosix_wrap(m) { return S_ISDIR(m); }
 101
 102 foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
 103 #def inline int s_isfifo_PrelPosix_wrap(m) { return S_ISFIFO(m); }
 104
 105 #ifndef mingw32_TARGET_OS
 106 foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
 107 #def inline int s_issock_PrelPosix_wrap(m) { return S_ISSOCK(m); }
 108 #else
 109 s_issock :: CMode -> Bool
 110 s_issock cmode = False
 111 #endif
 112
 113 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 114 -- manpages and they seem to conflict), so we truncate using open/2.
 115 fileTruncate :: FilePath -> IO ()
 116 fileTruncate file = do
 117   let flags = o_WRONLY .|. o_TRUNC
 118   withCString file $ \file_cstr -> do
 119     fd <- fromIntegral `liftM`
 120             throwErrnoIfMinus1Retry "fileTruncate"
 121                 (c_open file_cstr (fromIntegral flags) 0o666)
 122     c_close fd
 123   return ()
 124
 125 -- ---------------------------------------------------------------------------
 126 -- Terminal-related stuff
 127
 128 fdIsTTY :: Int -> IO Bool
 129 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 130
 131 #ifndef mingw32_TARGET_OS
 132
 133 type Termios = ()
 134
 135 setEcho :: Int -> Bool -> IO ()
 136 setEcho fd on = do
 137   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 138     throwErrnoIfMinus1Retry "setEcho"
 139         (c_tcgetattr (fromIntegral fd) p_tios)
 140     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 141     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 142                     | otherwise = c_lflag .&. complement (#const ECHO)
 143     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 144     tcSetAttr fd (#const TCSANOW) p_tios
 145
 146 getEcho :: Int -> IO Bool
 147 getEcho fd = do
 148   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 149     throwErrnoIfMinus1Retry "setEcho"
 150         (c_tcgetattr (fromIntegral fd) p_tios)
 151     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 152     return ((c_lflag .&. (#const ECHO)) /= 0)
 153
 154 setCooked :: Int -> Bool -> IO ()
 155 setCooked fd cooked =
 156   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 157     throwErrnoIfMinus1Retry "setCooked"
 158         (c_tcgetattr (fromIntegral fd) p_tios)
 159
 160     -- turn on/off ICANON
 161     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 162     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 163                     | otherwise = c_lflag .&. complement (#const ICANON)
 164     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 165
 166     -- set VMIN & VTIME to 1/0 respectively
 167     when cooked $ do
 168             let c_cc  = (#ptr struct termios, c_cc) p_tios
 169                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 170                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 171             poke vmin  1
 172             poke vtime 0
 173
 174     tcSetAttr fd (#const TCSANOW) p_tios
 175
 176 -- tcsetattr() when invoked by a background process causes the process
 177 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 178 -- in its terminal flags (try it...).  This function provides a
 179 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 180 -- transparent.
 181
 182 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 183 tcSetAttr fd options p_tios = do
 184   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 185   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 186      c_sigemptyset p_sigset
 187      c_sigaddset   p_sigset (#const SIGTTOU)
 188      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 189      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 190          c_tcsetattr (fromIntegral fd) options p_tios
 191      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 192
 193 #else
 194
 195 -- bogus defns for win32
 196 setCooked :: Int -> Bool -> IO ()
 197 setCooked fd cooked = return ()
 198
 199 setEcho :: Int -> Bool -> IO ()
 200 setEcho fd on = return ()
 201
 202 getEcho :: Int -> IO Bool
 203 getEcho fd = return False
 204
 205 #endif
 206
 207 -- ---------------------------------------------------------------------------
 208 -- Turning on non-blocking for a file descriptor
 209
 210 #ifndef mingw32_TARGET_OS
 211
 212 setNonBlockingFD fd = do
 213   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 214                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 215   -- An error when setting O_NONBLOCK isn't fatal: on some systems
 216   -- there are certain file handles on which this will fail (eg. /dev/null
 217   -- on FreeBSD) so we throw away the return code from fcntl_write.
 218   fcntl_write (fromIntegral fd)
 219         (#const F_SETFL) (flags .|. #const O_NONBLOCK)
 220 #else
 221
 222 -- bogus defns for win32
 223 setNonBlockingFD fd = return ()
 224
 225 #endif
 226
 227 -- -----------------------------------------------------------------------------
 228 -- foreign imports
 229
 230 foreign import "stat" unsafe
 231    c_stat :: CString -> Ptr CStat -> IO CInt
 232
 233 foreign import "fstat" unsafe
 234    c_fstat :: CInt -> Ptr CStat -> IO CInt
 235
 236 #ifdef HAVE_LSTAT
 237 foreign import "lstat" unsafe
 238    c_lstat :: CString -> Ptr CStat -> IO CInt
 239 #endif
 240
 241 foreign import "open" unsafe
 242    c_open :: CString -> CInt -> CMode -> IO CInt
 243
 244 -- POSIX flags only:
 245 o_RDONLY    = (#const O_RDONLY)    :: CInt
 246 o_WRONLY    = (#const O_WRONLY)    :: CInt
 247 o_RDWR      = (#const O_RDWR)      :: CInt
 248 o_APPEND    = (#const O_APPEND)    :: CInt
 249 o_CREAT     = (#const O_CREAT)     :: CInt
 250 o_EXCL      = (#const O_EXCL)      :: CInt
 251 o_TRUNC     = (#const O_TRUNC)     :: CInt
 252
 253 #ifdef mingw32_TARGET_OS
 254 o_NOCTTY    = 0 :: CInt
 255 o_NONBLOCK  = 0 :: CInt
 256 #else
 257 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 258 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 259 #endif
 260
 261 #ifdef HAVE_O_BINARY
 262 o_BINARY    = (#const O_BINARY)    :: CInt
 263 #endif
 264
 265 foreign import "isatty" unsafe
 266    c_isatty :: CInt -> IO CInt
 267
 268 foreign import "close" unsafe
 269    c_close :: CInt -> IO CInt
 270
 271 foreign import "lseek" unsafe
 272    c_lseek :: CInt -> COff -> CInt -> IO COff
 273
 274 foreign import "write" unsafe
 275    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 276
 277 foreign import "read" unsafe
 278    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 279
 280 #ifndef mingw32_TARGET_OS
 281 foreign import "fcntl" unsafe
 282    fcntl_read  :: CInt -> CInt -> IO CInt
 283
 284 foreign import "fcntl" unsafe
 285    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 286
 287 foreign import "fork" unsafe
 288    fork :: IO CPid
 289
 290 foreign import "sigemptyset_PrelPosix_wrap" unsafe
 291    c_sigemptyset :: Ptr CSigset -> IO ()
 292 #def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); }
 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