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 || s_issock c_mode -> return Stream
  91         | s_isreg c_mode                     -> return RegularFile
  92         | otherwise                          -> ioException ioe_unknownfiletype
  93
  94 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
  95                         "unknown file type" Nothing
  96
  97 foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
  98 #def inline int s_isreg_PrelPosix_wrap(m) { return S_ISREG(m); }
  99
 100 foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
 101 #def inline int s_isdir_PrelPosix_wrap(m) { return S_ISDIR(m); }
 102
 103 foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
 104 #def inline int s_isfifo_PrelPosix_wrap(m) { return S_ISFIFO(m); }
 105
 106 #ifndef mingw32_TARGET_OS
 107 foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
 108 #def inline int s_issock_PrelPosix_wrap(m) { return S_ISSOCK(m); }
 109 #else
 110 s_issock :: CMode -> Bool
 111 s_issock cmode = False
 112 #endif
 113
 114 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 115 -- manpages and they seem to conflict), so we truncate using open/2.
 116 fileTruncate :: FilePath -> IO ()
 117 fileTruncate file = do
 118   let flags = o_WRONLY .|. o_TRUNC
 119   withCString file $ \file_cstr -> do
 120     fd <- fromIntegral `liftM`
 121             throwErrnoIfMinus1Retry "fileTruncate"
 122                 (c_open file_cstr (fromIntegral flags) 0o666)
 123     c_close fd
 124   return ()
 125
 126 -- ---------------------------------------------------------------------------
 127 -- Terminal-related stuff
 128
 129 fdIsTTY :: Int -> IO Bool
 130 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 131
 132 #ifndef mingw32_TARGET_OS
 133
 134 type Termios = ()
 135
 136 setEcho :: Int -> Bool -> IO ()
 137 setEcho fd on = do
 138   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 139     throwErrnoIfMinus1Retry "setEcho"
 140         (c_tcgetattr (fromIntegral fd) p_tios)
 141     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 142     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 143                     | otherwise = c_lflag .&. complement (#const ECHO)
 144     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 145     tcSetAttr fd (#const TCSANOW) p_tios
 146
 147 getEcho :: Int -> IO Bool
 148 getEcho fd = do
 149   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 150     throwErrnoIfMinus1Retry "setEcho"
 151         (c_tcgetattr (fromIntegral fd) p_tios)
 152     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 153     return ((c_lflag .&. (#const ECHO)) /= 0)
 154
 155 setCooked :: Int -> Bool -> IO ()
 156 setCooked fd cooked =
 157   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 158     throwErrnoIfMinus1Retry "setCooked"
 159         (c_tcgetattr (fromIntegral fd) p_tios)
 160
 161     -- turn on/off ICANON
 162     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 163     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 164                     | otherwise = c_lflag .&. complement (#const ICANON)
 165     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 166
 167     -- set VMIN & VTIME to 1/0 respectively
 168     when cooked $ do
 169             let c_cc  = (#ptr struct termios, c_cc) p_tios
 170                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 171                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 172             poke vmin  1
 173             poke vtime 0
 174
 175     tcSetAttr fd (#const TCSANOW) p_tios
 176
 177 -- tcsetattr() when invoked by a background process causes the process
 178 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 179 -- in its terminal flags (try it...).  This function provides a
 180 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 181 -- transparent.
 182
 183 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 184 tcSetAttr fd options p_tios = do
 185   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 186   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 187      c_sigemptyset p_sigset
 188      c_sigaddset   p_sigset (#const SIGTTOU)
 189      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 190      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 191          c_tcsetattr (fromIntegral fd) options p_tios
 192      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 193
 194 #else
 195
 196 -- bogus defns for win32
 197 setCooked :: Int -> Bool -> IO ()
 198 setCooked fd cooked = return ()
 199
 200 setEcho :: Int -> Bool -> IO ()
 201 setEcho fd on = return ()
 202
 203 getEcho :: Int -> IO Bool
 204 getEcho fd = return False
 205
 206 #endif
 207
 208 -- ---------------------------------------------------------------------------
 209 -- Turning on non-blocking for a file descriptor
 210
 211 #ifndef mingw32_TARGET_OS
 212
 213 setNonBlockingFD fd = do
 214   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 215                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 216   -- An error when setting O_NONBLOCK isn't fatal: on some systems
 217   -- there are certain file handles on which this will fail (eg. /dev/null
 218   -- on FreeBSD) so we throw away the return code from fcntl_write.
 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_PrelPosix_wrap" unsafe
 292    c_sigemptyset :: Ptr CSigset -> IO ()
 293 #def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); }
 294
 295 foreign import "sigaddset" unsafe
 296    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 297
 298 foreign import "sigprocmask" unsafe
 299    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 300
 301 foreign import "tcgetattr" unsafe
 302    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 303
 304 foreign import "tcsetattr" unsafe
 305    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 306
 307 foreign import "unlink" unsafe
 308    c_unlink :: CString -> IO CInt
 309
 310 foreign import "waitpid" unsafe
 311    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 312 #endif