X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FPosix%2FInternals.hs;h=2a6126cdc0fc4965e8a7d1032f446cac0cabff31;hb=41e8fba828acbae1751628af50849f5352b27873;hp=fbac648e78e550db28b7f69da49361a7867910d8;hpb=a4d271497da4479239a3fbbeb860e819b5fb0a29;p=ghc-base.git

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index fbac648..2a6126c 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -37,7 +37,7 @@ import System.Posix.Types
 import Foreign
 import Foreign.C
 
-import Data.Bits
+-- import Data.Bits
 import Data.Maybe
 
 #if !defined(HTYPE_TCFLAG_T)
@@ -48,25 +48,27 @@ import System.IO.Error
 import GHC.Base
 import GHC.Num
 import GHC.Real
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.IOMode
+import GHC.IO.Exception
+import GHC.IO.Device
 #elif __HUGS__
 import Hugs.Prelude (IOException(..), IOErrorType(..))
 import Hugs.IO (IOMode(..))
 #elif __NHC__
+import GHC.IO.Device	-- yes, I know, but its portable, really!
 import System.IO
 import Control.Exception
 import DIOError
 #endif
 
 #ifdef __HUGS__
-{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
+{-# CFILES cbits/PrelIOUtils.c cbits/consUtils.c #-}
 #endif
 
 -- ---------------------------------------------------------------------------
 -- Types
 
-type CDir       = ()
-type CDirent    = ()
 type CFLock     = ()
 type CGroup     = ()
 type CLconv     = ()
@@ -80,9 +82,7 @@ type CTms       = ()
 type CUtimbuf   = ()
 type CUtsname   = ()
 
-#ifndef __GLASGOW_HASKELL__
 type FD = CInt
-#endif
 
 -- ---------------------------------------------------------------------------
 -- stat()-related stuff
@@ -90,7 +90,7 @@ type FD = CInt
 fdFileSize :: FD -> IO Integer
 fdFileSize fd = 
   allocaBytes sizeof_stat $ \ p_stat -> do
-    throwErrnoIfMinus1Retry "fileSize" $
+    throwErrnoIfMinus1Retry_ "fileSize" $
         c_fstat fd p_stat
     c_mode <- st_mode p_stat :: IO CMode 
     if not (s_isreg c_mode)
@@ -99,33 +99,30 @@ fdFileSize fd =
       c_size <- st_size p_stat
       return (fromIntegral c_size)
 
-data FDType  = Directory | Stream | RegularFile | RawDevice
-               deriving (Eq)
-
-fileType :: FilePath -> IO FDType
+fileType :: FilePath -> IO IODeviceType
 fileType file =
   allocaBytes sizeof_stat $ \ p_stat -> do
-  withCString file $ \p_file -> do
-    throwErrnoIfMinus1Retry "fileType" $
+  withFilePath file $ \p_file -> do
+    throwErrnoIfMinus1Retry_ "fileType" $
       c_stat p_file p_stat
     statGetType p_stat
 
 -- NOTE: On Win32 platforms, this will only work with file descriptors
 -- referring to file handles. i.e., it'll fail for socket FDs.
-fdStat :: FD -> IO (FDType, CDev, CIno)
+fdStat :: FD -> IO (IODeviceType, CDev, CIno)
 fdStat fd = 
   allocaBytes sizeof_stat $ \ p_stat -> do
-    throwErrnoIfMinus1Retry "fdType" $
+    throwErrnoIfMinus1Retry_ "fdType" $
         c_fstat fd p_stat
     ty <- statGetType p_stat
     dev <- st_dev p_stat
     ino <- st_ino p_stat
     return (ty,dev,ino)
     
-fdType :: FD -> IO FDType
+fdType :: FD -> IO IODeviceType
 fdType fd = do (ty,_,_) <- fdStat fd; return ty
 
-statGetType :: Ptr CStat -> IO FDType
+statGetType :: Ptr CStat -> IO IODeviceType
 statGetType p_stat = do
   c_mode <- st_mode p_stat :: IO CMode
   case () of
@@ -149,16 +146,6 @@ ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
 ioe_unknownfiletype = UserError "fdType" "unknown file type"
 #endif
 
-#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
-closeFd :: Bool -> CInt -> IO CInt
-closeFd isStream fd 
-  | isStream  = c_closesocket fd
-  | otherwise = c_close fd
-
-foreign import stdcall unsafe "HsBase.h closesocket"
-   c_closesocket :: CInt -> IO CInt
-#endif
-
 fdGetMode :: FD -> IO IOMode
 #if defined(mingw32_HOST_OS) || defined(__MINGW32__)
 fdGetMode _ = do
@@ -183,12 +170,17 @@ fdGetMode fd = do
           
     return mode
 
+#ifdef mingw32_HOST_OS
+withFilePath :: FilePath -> (CWString -> IO a) -> IO a
+withFilePath = withCWString 
+#else
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath = withCString
+#endif
+
 -- ---------------------------------------------------------------------------
 -- Terminal-related stuff
 
-fdIsTTY :: FD -> IO Bool
-fdIsTTY fd = c_isatty fd >>= return.toBool
-
 #if defined(HTYPE_TCFLAG_T)
 
 setEcho :: FD -> Bool -> IO ()
@@ -227,7 +219,7 @@ setCooked fd cooked =
 tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
 tcSetAttr fd fun = do
      allocaBytes sizeof_termios  $ \p_tios -> do
-        throwErrnoIfMinus1Retry "tcSetAttr"
+        throwErrnoIfMinus1Retry_ "tcSetAttr"
            (c_tcgetattr fd p_tios)
 
 #ifdef __GLASGOW_HASKELL__
@@ -248,13 +240,17 @@ tcSetAttr fd fun = do
         -- transparent.
         allocaBytes sizeof_sigset_t $ \ p_sigset -> do
           allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
-             c_sigemptyset p_sigset
-             c_sigaddset   p_sigset const_sigttou
-             c_sigprocmask const_sig_block p_sigset p_old_sigset
+             throwErrnoIfMinus1_ "sigemptyset" $
+                 c_sigemptyset p_sigset
+             throwErrnoIfMinus1_ "sigaddset" $
+                 c_sigaddset   p_sigset const_sigttou
+             throwErrnoIfMinus1_ "sigprocmask" $
+                 c_sigprocmask const_sig_block p_sigset p_old_sigset
              r <- fun p_tios  -- do the business
              throwErrnoIfMinus1Retry_ "tcSetAttr" $
                  c_tcsetattr fd const_tcsanow p_tios
-             c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+             throwErrnoIfMinus1_ "sigprocmask" $
+                 c_sigprocmask const_sig_setmask p_old_sigset nullPtr
              return r
 
 #ifdef __GLASGOW_HASKELL__
@@ -315,26 +311,31 @@ foreign import ccall unsafe "consUtils.h set_console_echo__"
 foreign import ccall unsafe "consUtils.h get_console_echo__"
    get_console_echo :: CInt -> IO CInt
 
+foreign import ccall unsafe "consUtils.h is_console__"
+   is_console :: CInt -> IO CInt
+
 #endif
 
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
-setNonBlockingFD :: FD -> IO ()
+setNonBlockingFD :: FD -> Bool -> IO ()
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-setNonBlockingFD fd = do
+setNonBlockingFD fd set = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                  (c_fcntl_read fd const_f_getfl)
-  -- An error when setting O_NONBLOCK isn't fatal: on some systems 
-  -- there are certain file handles on which this will fail (eg. /dev/null
-  -- on FreeBSD) so we throw away the return code from fcntl_write.
-  unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
-    c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))
+  let flags' | set       = flags .|. o_NONBLOCK
+             | otherwise = flags .&. complement o_NONBLOCK
+  unless (flags == flags') $ do
+    -- An error when setting O_NONBLOCK isn't fatal: on some systems
+    -- there are certain file handles on which this will fail (eg. /dev/null
+    -- on FreeBSD) so we throw away the return code from fcntl_write.
+    _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags')
     return ()
 #else
 
 -- bogus defns for win32
-setNonBlockingFD _ = return ()
+setNonBlockingFD _ _ = return ()
 
 #endif
 
@@ -344,14 +345,19 @@ setNonBlockingFD _ = return ()
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 setCloseOnExec :: FD -> IO ()
 setCloseOnExec fd = do
-  throwErrnoIfMinus1 "setCloseOnExec" $
+  throwErrnoIfMinus1_ "setCloseOnExec" $
     c_fcntl_write fd const_f_setfd const_fd_cloexec
-  return ()
 #endif
 
 -- -----------------------------------------------------------------------------
 -- foreign imports
 
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+type CFilePath = CString
+#else
+type CFilePath = CWString
+#endif
+
 foreign import ccall unsafe "HsBase.h access"
    c_access :: CString -> CInt -> IO CInt
 
@@ -361,9 +367,6 @@ foreign import ccall unsafe "HsBase.h chmod"
 foreign import ccall unsafe "HsBase.h close"
    c_close :: CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h closedir" 
-   c_closedir :: Ptr CDir -> IO CInt
-
 foreign import ccall unsafe "HsBase.h creat"
    c_creat :: CString -> CMode -> IO CInt
 
@@ -388,31 +391,28 @@ foreign import ccall unsafe "HsBase.h __hscore_lseek"
 #endif
 
 foreign import ccall unsafe "HsBase.h __hscore_lstat"
-   lstat :: CString -> Ptr CStat -> IO CInt
+   lstat :: CFilePath -> Ptr CStat -> IO CInt
 
 foreign import ccall unsafe "HsBase.h __hscore_open"
-   c_open :: CString -> CInt -> CMode -> IO CInt
-
-foreign import ccall unsafe "HsBase.h opendir" 
-   c_opendir :: CString  -> IO (Ptr CDir)
-
-foreign import ccall unsafe "HsBase.h __hscore_mkdir"
-   mkdir :: CString -> CInt -> IO CInt
+   c_open :: CFilePath -> CInt -> CMode -> IO CInt
 
 foreign import ccall unsafe "HsBase.h read" 
-   c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+   c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
-foreign import ccall unsafe "HsBase.h rewinddir"
-   c_rewinddir :: Ptr CDir -> IO ()
+foreign import ccall safe "HsBase.h read"
+   c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
 foreign import ccall unsafe "HsBase.h __hscore_stat"
-   c_stat :: CString -> Ptr CStat -> IO CInt
+   c_stat :: CFilePath -> Ptr CStat -> IO CInt
 
 foreign import ccall unsafe "HsBase.h umask"
    c_umask :: CMode -> IO CMode
 
 foreign import ccall unsafe "HsBase.h write" 
-   c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+   c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+
+foreign import ccall safe "HsBase.h write"
+   c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
 foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
    c_ftruncate :: CInt -> COff -> IO CInt
@@ -460,26 +460,13 @@ foreign import ccall unsafe "HsBase.h tcgetattr"
 foreign import ccall unsafe "HsBase.h tcsetattr"
    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
 
-foreign import ccall unsafe "HsBase.h utime"
+foreign import ccall unsafe "HsBase.h __hscore_utime"
    c_utime :: CString -> Ptr CUtimbuf -> IO CInt
 
 foreign import ccall unsafe "HsBase.h waitpid"
    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 #endif
 
--- traversing directories
-foreign import ccall unsafe "dirUtils.h __hscore_readdir"
-  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
- 
-foreign import ccall unsafe "HsBase.h __hscore_free_dirent"
-  freeDirEnt  :: Ptr CDirent -> IO ()
- 
-foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"
-  end_of_dir :: CInt
- 
-foreign import ccall unsafe "HsBase.h __hscore_d_name"
-  d_name :: Ptr CDirent -> IO CString
-
 -- POSIX flags only:
 foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt
 foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
@@ -551,3 +538,8 @@ foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode ->
 #else
 s_issock _ = False
 #endif
+
+foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt