ghc/lib/std/PrelPosix.hsc

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