X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FPosix%2FInternals.hs;h=c4bb446841715f50520cfb65d534472ac1b6767c;hb=d2063b5b0be014545b21819172c87756efcb0b0c;hp=6eddda63b4757ad36c4fcd9db8f6f1cbf2880131;hpb=9fdbf0f92b42f8e64b1f6a4c2c60fe4595852b51;p=ghc-base.git

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 6eddda6..c4bb446 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -22,9 +23,15 @@
 -- #hide
 module System.Posix.Internals where
 
-#include "HsBaseConfig.h"
+#ifdef __NHC__
+#define HTYPE_TCFLAG_T
+#else
+# include "HsBaseConfig.h"
+#endif
 
+#if ! (defined(mingw32_HOST_OS) || defined(__MINGW32__))
 import Control.Monad
+#endif
 import System.Posix.Types
 
 import Foreign
@@ -33,16 +40,25 @@ import Foreign.C
 import Data.Bits
 import Data.Maybe
 
+#if !defined(HTYPE_TCFLAG_T)
+import System.IO.Error
+#endif
+
 #if __GLASGOW_HASKELL__
 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(..))
-#else
+#elif __NHC__
 import System.IO
+import Control.Exception
+import DIOError
 #endif
 
 #ifdef __HUGS__
@@ -67,9 +83,7 @@ type CTms       = ()
 type CUtimbuf   = ()
 type CUtsname   = ()
 
-#ifndef __GLASGOW_HASKELL__
 type FD = CInt
-#endif
 
 -- ---------------------------------------------------------------------------
 -- stat()-related stuff
@@ -83,13 +97,10 @@ fdFileSize fd =
     if not (s_isreg c_mode)
         then return (-1)
         else do
-    c_size <- st_size p_stat
-    return (fromIntegral c_size)
-
-data FDType  = Directory | Stream | RegularFile | RawDevice
-               deriving (Eq)
+      c_size <- st_size p_stat
+      return (fromIntegral c_size)
 
-fileType :: FilePath -> IO FDType
+fileType :: FilePath -> IO IODeviceType
 fileType file =
   allocaBytes sizeof_stat $ \ p_stat -> do
   withCString file $ \p_file -> do
@@ -99,7 +110,7 @@ fileType file =
 
 -- 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" $
@@ -109,9 +120,10 @@ fdStat fd =
     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 IODeviceType
 statGetType p_stat = do
   c_mode <- st_mode p_stat :: IO CMode
   case () of
@@ -123,27 +135,26 @@ statGetType p_stat = do
         | s_isblk c_mode        -> return RawDevice
         | otherwise             -> ioError ioe_unknownfiletype
     
-
+ioe_unknownfiletype :: IOException
+#ifndef __NHC__
 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
-                        "unknown file type" Nothing
-
-#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
+                        "unknown file type"
+#  if __GLASGOW_HASKELL__
+                        Nothing
+#  endif
+                        Nothing
+#else
+ioe_unknownfiletype = UserError "fdType" "unknown file type"
 #endif
 
 fdGetMode :: FD -> IO IOMode
-fdGetMode fd = do
 #if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+fdGetMode _ = do
     -- We don't have a way of finding out which flags are set on FDs
     -- on Windows, so make a handle that thinks that anything goes.
     let flags = o_RDWR
 #else
+fdGetMode fd = do
     flags <- throwErrnoIfMinus1Retry "fdGetMode" 
                 (c_fcntl_read fd const_f_getfl)
 #endif
@@ -163,35 +174,32 @@ fdGetMode fd = do
 -- ---------------------------------------------------------------------------
 -- Terminal-related stuff
 
-fdIsTTY :: FD -> IO Bool
-fdIsTTY fd = c_isatty fd >>= return.toBool
-
 #if defined(HTYPE_TCFLAG_T)
 
 setEcho :: FD -> Bool -> IO ()
 setEcho fd on = do
   tcSetAttr fd $ \ p_tios -> do
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    let new_c_lflag
-         | on        = c_lflag .|. fromIntegral const_echo
-         | otherwise = c_lflag .&. complement (fromIntegral const_echo)
-    poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    let new_lflag
+         | on        = lflag .|. fromIntegral const_echo
+         | otherwise = lflag .&. complement (fromIntegral const_echo)
+    poke_c_lflag p_tios (new_lflag :: CTcflag)
 
 getEcho :: FD -> IO Bool
 getEcho fd = do
   tcSetAttr fd $ \ p_tios -> do
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    return ((c_lflag .&. fromIntegral const_echo) /= 0)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    return ((lflag .&. fromIntegral const_echo) /= 0)
 
 setCooked :: FD -> Bool -> IO ()
 setCooked fd cooked = 
   tcSetAttr fd $ \ p_tios -> do
 
     -- turn on/off ICANON
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    let new_c_lflag | cooked    = c_lflag .|. (fromIntegral const_icanon)
-                    | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
-    poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    let new_lflag | cooked    = lflag .|. (fromIntegral const_icanon)
+                  | otherwise = lflag .&. complement (fromIntegral const_icanon)
+    poke_c_lflag p_tios (new_lflag :: CTcflag)
 
     -- set VMIN & VTIME to 1/0 respectively
     when (not cooked) $ do
@@ -224,7 +232,7 @@ tcSetAttr fd fun = do
         -- wrapper which temporarily blocks SIGTTOU around the call, making it
         -- transparent.
         allocaBytes sizeof_sigset_t $ \ p_sigset -> do
-        allocaBytes sizeof_sigset_t $ \ p_old_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
@@ -259,8 +267,13 @@ setCooked fd cooked = do
    then ioError (ioe_unk_error "setCooked" "failed to set buffering")
    else return ()
 
+ioe_unk_error :: String -> String -> IOException
 ioe_unk_error loc msg 
- = IOError Nothing OtherError loc msg Nothing
+#ifndef __NHC__
+ = ioeSetErrorString (mkIOError OtherError loc Nothing Nothing) msg
+#else
+ = UserError loc msg
+#endif
 
 -- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
 -- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
@@ -292,8 +305,8 @@ foreign import ccall unsafe "consUtils.h get_console_echo__"
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
+setNonBlockingFD :: FD -> IO ()
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
 setNonBlockingFD fd = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                  (c_fcntl_read fd const_f_getfl)
@@ -306,8 +319,19 @@ setNonBlockingFD fd = do
 #else
 
 -- bogus defns for win32
-setNonBlockingFD fd = return ()
+setNonBlockingFD _ = return ()
+
+#endif
 
+-- -----------------------------------------------------------------------------
+-- Set close-on-exec for a file descriptor
+
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+setCloseOnExec :: FD -> IO ()
+setCloseOnExec fd = do
+  throwErrnoIfMinus1 "setCloseOnExec" $
+    c_fcntl_write fd const_f_setfd const_fd_cloexec
+  return ()
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -319,9 +343,6 @@ foreign import ccall unsafe "HsBase.h access"
 foreign import ccall unsafe "HsBase.h chmod"
    c_chmod :: CString -> CMode -> IO CInt
 
-foreign import ccall unsafe "HsBase.h chdir"
-   c_chdir :: CString -> IO CInt
-
 foreign import ccall unsafe "HsBase.h close"
    c_close :: CInt -> IO CInt
 
@@ -340,9 +361,6 @@ foreign import ccall unsafe "HsBase.h dup2"
 foreign import ccall unsafe "HsBase.h __hscore_fstat"
    c_fstat :: CInt -> Ptr CStat -> IO CInt
 
-foreign import ccall unsafe "HsBase.h getcwd"
-   c_getcwd   :: Ptr CChar -> CSize -> IO (Ptr CChar)
-
 foreign import ccall unsafe "HsBase.h isatty"
    c_isatty :: CInt -> IO CInt
 
@@ -369,15 +387,9 @@ foreign import ccall unsafe "HsBase.h __hscore_mkdir"
 foreign import ccall unsafe "HsBase.h read" 
    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 
-foreign import ccall unsafe "dirUtils.h __hscore_renameFile"
-   c_rename :: CString -> CString -> IO CInt
-                     
 foreign import ccall unsafe "HsBase.h rewinddir"
    c_rewinddir :: Ptr CDir -> IO ()
 
-foreign import ccall unsafe "HsBase.h rmdir"
-   c_rmdir :: CString -> IO CInt
-
 foreign import ccall unsafe "HsBase.h __hscore_stat"
    c_stat :: CString -> Ptr CStat -> IO CInt
 
@@ -397,13 +409,13 @@ foreign import ccall unsafe "HsBase.h getpid"
    c_getpid :: IO CPid
 
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_read"
    c_fcntl_read  :: CInt -> CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_write"
    c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
 
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_lock"
    c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt
 
 foreign import ccall unsafe "HsBase.h fork"
@@ -505,6 +517,8 @@ foreign import ccall unsafe "HsBase.h __hscore_sig_block"    const_sig_block ::
 foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :: CInt
 foreign import ccall unsafe "HsBase.h __hscore_f_getfl"      const_f_getfl :: CInt
 foreign import ccall unsafe "HsBase.h __hscore_f_setfl"      const_f_setfl :: CInt
+foreign import ccall unsafe "HsBase.h __hscore_f_setfd"      const_f_setfd :: CInt
+foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec"   const_fd_cloexec :: CLong
 
 #if defined(HTYPE_TCFLAG_T)
 foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int
@@ -515,11 +529,15 @@ foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr C
 foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)
 #endif
 
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt
 s_issock :: CMode -> Bool
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 s_issock cmode = c_s_issock cmode /= 0
+foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt
 #else
-s_issock :: CMode -> Bool
-s_issock cmode = False
+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