ghc/lib/std/PrelPosix.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: PrelPosix.hsc,v 1.13 2001/08/23 10:36:50 sewardj 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   throwErrnoIfMinus1Retry "setNonBlockingFD"
 216         (fcntl_write (fromIntegral fd)
 217            (#const F_SETFL) (flags .|. #const O_NONBLOCK))
 218 #else
 219
 220 -- bogus defns for win32
 221 setNonBlockingFD fd = return ()
 222
 223 #endif
 224
 225 -- -----------------------------------------------------------------------------
 226 -- foreign imports
 227
 228 foreign import "stat" unsafe
 229    c_stat :: CString -> Ptr CStat -> IO CInt
 230
 231 foreign import "fstat" unsafe
 232    c_fstat :: CInt -> Ptr CStat -> IO CInt
 233
 234 #ifdef HAVE_LSTAT
 235 foreign import "lstat" unsafe
 236    c_lstat :: CString -> Ptr CStat -> IO CInt
 237 #endif
 238
 239 foreign import "open" unsafe
 240    c_open :: CString -> CInt -> CMode -> IO CInt
 241
 242 -- POSIX flags only:
 243 o_RDONLY    = (#const O_RDONLY)    :: CInt
 244 o_WRONLY    = (#const O_WRONLY)    :: CInt
 245 o_RDWR      = (#const O_RDWR)      :: CInt
 246 o_APPEND    = (#const O_APPEND)    :: CInt
 247 o_CREAT     = (#const O_CREAT)     :: CInt
 248 o_EXCL      = (#const O_EXCL)      :: CInt
 249 o_TRUNC     = (#const O_TRUNC)     :: CInt
 250
 251 #ifdef mingw32_TARGET_OS
 252 o_NOCTTY    = 0 :: CInt
 253 o_NONBLOCK  = 0 :: CInt
 254 #else
 255 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 256 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 257 #endif
 258
 259 #ifdef HAVE_O_BINARY
 260 o_BINARY    = (#const O_BINARY)    :: CInt
 261 #endif
 262
 263 foreign import "isatty" unsafe
 264    c_isatty :: CInt -> IO CInt
 265
 266 foreign import "close" unsafe
 267    c_close :: CInt -> IO CInt
 268
 269 foreign import "lseek" unsafe
 270    c_lseek :: CInt -> COff -> CInt -> IO COff
 271
 272 foreign import "write" unsafe
 273    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 274
 275 foreign import "read" unsafe
 276    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 277
 278 #ifndef mingw32_TARGET_OS
 279 foreign import "fcntl" unsafe
 280    fcntl_read  :: CInt -> CInt -> IO CInt
 281
 282 foreign import "fcntl" unsafe
 283    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 284
 285 foreign import "fork" unsafe
 286    fork :: IO CPid
 287
 288 foreign import "sigemptyset_PrelPosix_wrap" unsafe
 289    c_sigemptyset :: Ptr CSigset -> IO ()
 290 #def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); }
 291
 292 foreign import "sigaddset" unsafe
 293    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 294
 295 foreign import "sigprocmask" unsafe
 296    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 297
 298 foreign import "tcgetattr" unsafe
 299    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 300
 301 foreign import "tcsetattr" unsafe
 302    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 303
 304 foreign import "unlink" unsafe
 305    c_unlink :: CString -> IO CInt
 306
 307 foreign import "waitpid" unsafe
 308    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 309 #endif