[project @ 2002-09-06 14:34:15 by simonmar]

[haskell-directory.git] / GHC / Posix.hs

diff --git a/GHC/Posix.hs b/GHC/Posix.hs
index f69d57b..819f2f4 100644 (file)
--- a/GHC/Posix.hs
+++ b/GHC/Posix.hs
@@ -1,18 +1,29 @@
 {-# OPTIONS -fno-implicit-prelude #-}
 
--- ---------------------------------------------------------------------------
--- $Id: Posix.hs,v 1.5 2002/03/26 10:44:32 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Posix
+-- Copyright   :  (c) The University of Glasgow, 1992-2002
+-- License     :  see libraries/base/LICENSE
+-- 
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable
 --
--- POSIX support layer for the standard libraries
+-- POSIX support layer for the standard libraries.
+-- This library is built on *every* platform, including Win32.
 --
 -- Non-posix compliant in order to support the following features:
 --     * S_ISSOCK (no sockets in POSIX)
+--
+-----------------------------------------------------------------------------
 
 module GHC.Posix where
 
 #include "config.h"
 
 import Control.Monad
+import System.Posix.Types
 
 import Foreign
 import Foreign.C
@@ -43,24 +54,6 @@ type CTms    = ()
 type CUtimbuf   = ()
 type CUtsname   = ()
 
-type CDev    = HTYPE_DEV_T
-type CIno    = HTYPE_INO_T
-type CMode   = HTYPE_MODE_T
-type COff    = HTYPE_OFF_T
-type CPid    = HTYPE_PID_T
-
-#ifdef mingw32_TARGET_OS
-type CSsize  = HTYPE_SIZE_T
-#else
-type CGid    = HTYPE_GID_T
-type CNlink  = HTYPE_NLINK_T
-type CSsize  = HTYPE_SSIZE_T
-type CUid    = HTYPE_UID_T
-type CCc     = HTYPE_CC_T
-type CSpeed  = HTYPE_SPEED_T
-type CTcflag = HTYPE_TCFLAG_T
-#endif
-
 -- ---------------------------------------------------------------------------
 -- stat()-related stuff
 
@@ -126,10 +119,34 @@ closeFd isStream fd
   | isStream  = c_closesocket fd
   | otherwise = c_close fd
 
-foreign import ccall unsafe "closesocket"
+foreign import stdcall unsafe "closesocket"
    c_closesocket :: CInt -> IO CInt
 #endif
 
+fdGetMode :: Int -> IO IOMode
+fdGetMode fd = do
+#ifdef mingw32_TARGET_OS
+    flags1 <- throwErrnoIfMinus1Retry "fdGetMode" 
+                (c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
+    flags  <- throwErrnoIfMinus1Retry "fdGetMode" 
+                (c__setmode (fromIntegral fd) (fromIntegral flags1))
+#else
+    flags <- throwErrnoIfMinus1Retry "fdGetMode" 
+               (c_fcntl_read (fromIntegral fd) const_f_getfl)
+#endif
+    let
+       wH  = (flags .&. o_WRONLY) /= 0
+       aH  = (flags .&. o_APPEND) /= 0
+       rwH = (flags .&. o_RDWR) /= 0
+
+       mode
+        | wH && aH  = AppendMode
+        | wH        = WriteMode
+        | rwH       = ReadWriteMode
+        | otherwise = ReadMode
+         
+    return mode
+
 -- ---------------------------------------------------------------------------
 -- Terminal-related stuff
 
@@ -196,18 +213,43 @@ tcSetAttr fd options p_tios = do
      throwErrnoIfMinus1Retry_ "tcSetAttr" $
         c_tcsetattr (fromIntegral fd) options p_tios
      c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+     return ()
 
 #else
 
 -- bogus defns for win32
 setCooked :: Int -> Bool -> IO ()
-setCooked fd cooked = return ()
+setCooked fd cooked = do
+  x <- set_console_buffering (fromIntegral fd) (if cooked then 1 else 0)
+  if (x /= 0)
+   then ioException (ioe_unk_error "setCooked" "failed to set buffering")
+   else return ()
+
+ioe_unk_error loc msg 
+ = IOError Nothing OtherError loc msg Nothing
 
 setEcho :: Int -> Bool -> IO ()
-setEcho fd on = return ()
+setEcho fd on = do
+  x <- set_console_echo (fromIntegral fd) (if on then 1 else 0)
+  if (x /= 0)
+   then ioException (ioe_unk_error "setEcho" "failed to set echoing")
+   else return ()
 
 getEcho :: Int -> IO Bool
-getEcho fd = return False
+getEcho fd = do
+  r <- get_console_echo (fromIntegral fd)
+  if (r == (-1))
+   then ioException (ioe_unk_error "getEcho" "failed to get echoing")
+   else return (r == 1)
+
+foreign import ccall unsafe "consUtils.h set_console_buffering__"
+   set_console_buffering :: CInt -> CInt -> IO CInt
+
+foreign import ccall unsafe "consUtils.h set_console_echo__"
+   set_console_echo :: CInt -> CInt -> IO CInt
+
+foreign import ccall unsafe "consUtils.h get_console_echo__"
+   get_console_echo :: CInt -> IO CInt
 
 #endif
 
@@ -321,12 +363,12 @@ foreign import ccall unsafe "fcntl"
 foreign import ccall unsafe "fork"
    c_fork :: IO CPid 
 
+foreign import ccall unsafe "getpid"
+   c_getpid :: IO CPid
+
 foreign import ccall unsafe "fpathconf"
    c_fpathconf :: CInt -> CInt -> IO CLong
 
-foreign import ccall unsafe "__hscore_sigemptyset"
-   c_sigemptyset :: Ptr CSigset -> IO ()
-
 foreign import ccall unsafe "link"
    c_link :: CString -> CString -> IO CInt
 
@@ -339,11 +381,14 @@ foreign import ccall unsafe "pathconf"
 foreign import ccall unsafe "pipe"
    c_pipe :: Ptr CInt -> IO CInt
 
-foreign import ccall unsafe "sigaddset"
+foreign import ccall unsafe "__hscore_sigemptyset"
+   c_sigemptyset :: Ptr CSigset -> IO CInt
+
+foreign import ccall unsafe "__hscore_sigaddset"
    c_sigaddset :: Ptr CSigset -> CInt -> IO CInt
 
 foreign import ccall unsafe "sigprocmask"
-   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
+   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt
 
 foreign import ccall unsafe "tcgetattr"
    c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
@@ -359,6 +404,16 @@ foreign import ccall unsafe "utime"
 
 foreign import ccall unsafe "waitpid"
    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
+#else
+foreign import ccall unsafe "_setmode"
+   c__setmode :: CInt -> CInt -> IO CInt
+
+--   /* Set "stdin" to have binary mode: */
+--   result = _setmode( _fileno( stdin ), _O_BINARY );
+--   if( result == -1 )
+--      perror( "Cannot set mode" );
+--   else
+--      printf( "'stdin' successfully changed to binary mode\n" );
 #endif
 
 -- POSIX flags only: