X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FPosix%2FInternals.hs;h=e5dbaaff588c6f7415ca17dc51158ccbc89484c5;hb=3b49c6c0b4f4a638e773dbd978dbdd8d238de067;hp=ae46999b488af1c5c56b035ffc5d12494711958a;hpb=19faa78e1d518839700c62b37f88f74703c4161f;p=haskell-directory.git

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index ae46999..e5dbaaf 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -1,7 +1,6 @@
 {-# OPTIONS -fno-implicit-prelude #-}
 
 -----------------------------------------------------------------------------
--- #hide
 -- |
 -- Module      :  System.Posix.Internals
 -- Copyright   :  (c) The University of Glasgow, 1992-2002
@@ -19,6 +18,7 @@
 --
 -----------------------------------------------------------------------------
 
+-- #hide
 module System.Posix.Internals where
 
 #include "config.h"
@@ -43,6 +43,9 @@ import System.IO
 
 #ifdef __HUGS__
 import Hugs.Prelude (IOException(..), IOErrorType(..))
+
+{-# CBITS PrelIOUtils.c dirUtils.c consUtils.c #-}
+ioException = ioError
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -127,7 +130,7 @@ fileTruncate file = do
     c_close fd
   return ()
 
-#ifdef mingw32_TARGET_OS
+#if defined(mingw32_TARGET_OS) || defined(__MINGW32__)
 closeFd :: Bool -> CInt -> IO CInt
 closeFd isStream fd 
   | isStream  = c_closesocket fd
@@ -139,7 +142,7 @@ foreign import stdcall unsafe "HsBase.h closesocket"
 
 fdGetMode :: Int -> IO IOMode
 fdGetMode fd = do
-#ifdef mingw32_TARGET_OS
+#if defined(mingw32_TARGET_OS) || defined(__MINGW32__)
     flags1 <- throwErrnoIfMinus1Retry "fdGetMode" 
                 (c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
     flags  <- throwErrnoIfMinus1Retry "fdGetMode" 
@@ -167,33 +170,26 @@ fdGetMode fd = do
 fdIsTTY :: Int -> IO Bool
 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 
-#ifndef mingw32_TARGET_OS
+#if defined(HTYPE_TCFLAG_T)
 
 setEcho :: Int -> Bool -> IO ()
 setEcho fd on = do
-  allocaBytes sizeof_termios  $ \p_tios -> do
-    throwErrnoIfMinus1Retry "setEcho"
-	(c_tcgetattr (fromIntegral fd) p_tios)
+  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)
-    tcSetAttr fd const_tcsanow p_tios
 
 getEcho :: Int -> IO Bool
 getEcho fd = do
-  allocaBytes sizeof_termios  $ \p_tios -> do
-    throwErrnoIfMinus1Retry "setEcho"
-	(c_tcgetattr (fromIntegral fd) p_tios)
+  tcSetAttr fd $ \ p_tios -> do
     c_lflag <- c_lflag p_tios :: IO CTcflag
     return ((c_lflag .&. fromIntegral const_echo) /= 0)
 
 setCooked :: Int -> Bool -> IO ()
 setCooked fd cooked = 
-  allocaBytes sizeof_termios  $ \p_tios -> do
-    throwErrnoIfMinus1Retry "setCooked"
-	(c_tcgetattr (fromIntegral fd) p_tios)
+  tcSetAttr fd $ \ p_tios -> do
 
     -- turn on/off ICANON
     c_lflag <- c_lflag p_tios :: IO CTcflag
@@ -209,25 +205,46 @@ setCooked fd cooked =
 	    poke vmin  1
 	    poke vtime 0
 
-    tcSetAttr fd const_tcsanow p_tios
-
--- tcsetattr() when invoked by a background process causes the process
--- to be sent SIGTTOU regardless of whether the process has TOSTOP set
--- in its terminal flags (try it...).  This function provides a
--- wrapper which temporarily blocks SIGTTOU around the call, making it
--- transparent.
-
-tcSetAttr :: FD -> CInt -> Ptr CTermios -> IO ()
-tcSetAttr fd options p_tios = do
-  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
-     throwErrnoIfMinus1Retry_ "tcSetAttr" $
-	 c_tcsetattr (fromIntegral fd) options p_tios
-     c_sigprocmask const_sig_setmask p_old_sigset nullPtr
-     return ()
+tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
+tcSetAttr fd fun = do
+     allocaBytes sizeof_termios  $ \p_tios -> do
+	throwErrnoIfMinus1Retry "tcSetAttr"
+	   (c_tcgetattr (fromIntegral fd) p_tios)
+
+#ifdef __GLASGOW_HASKELL__
+	-- Save a copy of termios, if this is a standard file descriptor.
+	-- These terminal settings are restored in hs_exit().
+	when (fd <= 2) $ do
+	  p <- get_saved_termios fd
+	  when (p == nullPtr) $ do
+	     saved_tios <- mallocBytes sizeof_termios
+	     copyBytes saved_tios p_tios sizeof_termios
+	     set_saved_termios fd saved_tios
+#endif
+
+	-- tcsetattr() when invoked by a background process causes the process
+	-- to be sent SIGTTOU regardless of whether the process has TOSTOP set
+	-- in its terminal flags (try it...).  This function provides a
+	-- 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
+	     c_sigemptyset p_sigset
+	     c_sigaddset   p_sigset const_sigttou
+	     c_sigprocmask const_sig_block p_sigset p_old_sigset
+	     r <- fun p_tios  -- do the business
+	     throwErrnoIfMinus1Retry_ "tcSetAttr" $
+		 c_tcsetattr (fromIntegral fd) const_tcsanow p_tios
+	     c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+	     return r
+
+#ifdef __GLASGOW_HASKELL__
+foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
+   get_saved_termios :: Int -> IO (Ptr CTermios)
+
+foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"
+   set_saved_termios :: Int -> (Ptr CTermios) -> IO ()
+#endif
 
 #else
 
@@ -265,13 +282,13 @@ getEcho fd = do
    then ioException (ioe_unk_error "getEcho" "failed to get echoing")
    else return (r == 1)
 
-foreign import ccall unsafe "HsBase.h consUtils.h set_console_buffering__"
+foreign import ccall unsafe "consUtils.h set_console_buffering__"
    set_console_buffering :: CInt -> CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h consUtils.h set_console_echo__"
+foreign import ccall unsafe "consUtils.h set_console_echo__"
    set_console_echo :: CInt -> CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h consUtils.h get_console_echo__"
+foreign import ccall unsafe "consUtils.h get_console_echo__"
    get_console_echo :: CInt -> IO CInt
 
 #endif
@@ -279,7 +296,7 @@ foreign import ccall unsafe "HsBase.h consUtils.h get_console_echo__"
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
-#ifndef mingw32_TARGET_OS
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
 
 setNonBlockingFD fd = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
@@ -287,7 +304,9 @@ setNonBlockingFD fd = 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 (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
+  unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
+    c_fcntl_write (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
+    return ()
 #else
 
 -- bogus defns for win32
@@ -322,7 +341,7 @@ foreign import ccall unsafe "HsBase.h dup"
 foreign import ccall unsafe "HsBase.h dup2"
    c_dup2 :: CInt -> CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h fstat"
+foreign import ccall unsafe "HsBase.h __hscore_fstat"
    c_fstat :: CInt -> Ptr CStat -> IO CInt
 
 foreign import ccall unsafe "HsBase.h getcwd"
@@ -331,13 +350,13 @@ foreign import ccall unsafe "HsBase.h getcwd"
 foreign import ccall unsafe "HsBase.h isatty"
    c_isatty :: CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h lseek"
+foreign import ccall unsafe "HsBase.h __hscore_lseek"
    c_lseek :: CInt -> COff -> CInt -> IO COff
 
 foreign import ccall unsafe "HsBase.h __hscore_lstat"
    lstat :: CString -> Ptr CStat -> IO CInt
 
-foreign import ccall unsafe "HsBase.h open"
+foreign import ccall unsafe "HsBase.h __hscore_open"
    c_open :: CString -> CInt -> CMode -> IO CInt
 
 foreign import ccall unsafe "HsBase.h opendir" 
@@ -349,10 +368,7 @@ 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 "HsBase.h readdir" 
-   c_readdir :: Ptr CDir -> IO (Ptr CDirent)
-
-foreign import ccall unsafe "HsBase.h rename"
+foreign import ccall unsafe "dirUtils.h __hscore_renameFile"
    c_rename :: CString -> CString -> IO CInt
 		     
 foreign import ccall unsafe "HsBase.h rewinddir"
@@ -361,7 +377,7 @@ foreign import ccall unsafe "HsBase.h rewinddir"
 foreign import ccall unsafe "HsBase.h rmdir"
    c_rmdir :: CString -> IO CInt
 
-foreign import ccall unsafe "HsBase.h stat"
+foreign import ccall unsafe "HsBase.h __hscore_stat"
    c_stat :: CString -> Ptr CStat -> IO CInt
 
 foreign import ccall unsafe "HsBase.h umask"
@@ -373,7 +389,7 @@ foreign import ccall unsafe "HsBase.h write"
 foreign import ccall unsafe "HsBase.h unlink"
    c_unlink :: CString -> IO CInt
 
-#ifndef mingw32_TARGET_OS
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
 foreign import ccall unsafe "HsBase.h fcntl"
    c_fcntl_read  :: CInt -> CInt -> IO CInt
 
@@ -389,18 +405,12 @@ foreign import ccall unsafe "HsBase.h fork"
 foreign import ccall unsafe "HsBase.h getpid"
    c_getpid :: IO CPid
 
-foreign import ccall unsafe "HsBase.h fpathconf"
-   c_fpathconf :: CInt -> CInt -> IO CLong
-
 foreign import ccall unsafe "HsBase.h link"
    c_link :: CString -> CString -> IO CInt
 
 foreign import ccall unsafe "HsBase.h mkfifo"
    c_mkfifo :: CString -> CMode -> IO CInt
 
-foreign import ccall unsafe "HsBase.h pathconf"
-   c_pathconf :: CString -> CInt -> IO CLong
-
 foreign import ccall unsafe "HsBase.h pipe"
    c_pipe :: Ptr CInt -> IO CInt
 
@@ -436,6 +446,19 @@ foreign import ccall unsafe "HsBase.h _setmode"
 --      printf( "'stdin' successfully changed to binary mode\n" );
 #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
@@ -472,7 +495,7 @@ foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :
 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
 
-#ifndef mingw32_TARGET_OS
+#if defined(HTYPE_TCFLAG_T)
 foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int
 foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
 
@@ -481,7 +504,7 @@ 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
 
-#ifndef mingw32_TARGET_OS
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
 foreign import ccall unsafe "HsBase.h __hscore_s_issock" s_issock :: CMode -> Bool
 #else
 s_issock :: CMode -> Bool