ghc/lib/std/PrelPosix.hsc

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