X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=System%2FPosix%2FInternals.hs;h=a1ee00b4d7b5fee6642836d8101d6fdfa4d1d50b;hb=2570f264ed329f04017d507250494eb0ab680d64;hp=e21a01c9d5d1ea9f665a681559b9b8e3d3f181fc;hpb=3bc707020c8d0f7a11b652c38d33f1d9c87d3ae7;p=haskell-directory.git

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index e21a01c..a1ee00b 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -8,7 +8,7 @@
 -- 
 -- Maintainer  :  cvs-ghc@haskell.org
 -- Stability   :  internal
--- Portability :  non-portable
+-- Portability :  non-portable (requires POSIX)
 --
 -- POSIX support layer for the standard libraries.
 -- This library is built on *every* platform, including Win32.
@@ -22,6 +22,7 @@
 module System.Posix.Internals where
 
 #include "ghcconfig.h"
+#include "HsBaseConfig.h"
 
 import Control.Monad
 import System.Posix.Types
@@ -44,8 +45,7 @@ import System.IO
 #ifdef __HUGS__
 import Hugs.Prelude (IOException(..), IOErrorType(..))
 
-{-# CBITS PrelIOUtils.c dirUtils.c consUtils.c #-}
-ioException = ioError
+{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -85,7 +85,7 @@ fdFileSize fd =
     c_size <- st_size p_stat :: IO COff
     return (fromIntegral c_size)
 
-data FDType  = Directory | Stream | RegularFile
+data FDType  = Directory | Stream | RegularFile | RawDevice
 	       deriving (Eq)
 
 fileType :: FilePath -> IO FDType
@@ -112,25 +112,15 @@ statGetType p_stat = do
         | s_isfifo c_mode || s_issock c_mode || s_ischr  c_mode
 			  	-> return Stream
 	| s_isreg c_mode	-> return RegularFile
+	 -- Q: map char devices to RawDevice too?
+	| s_isblk c_mode        -> return RawDevice
 	| otherwise		-> ioError ioe_unknownfiletype
     
 
 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
 			"unknown file type" Nothing
 
--- It isn't clear whether ftruncate is POSIX or not (I've read several
--- manpages and they seem to conflict), so we truncate using open/2.
-fileTruncate :: FilePath -> IO ()
-fileTruncate file = do
-  let flags = o_WRONLY .|. o_TRUNC
-  withCString file $ \file_cstr -> do
-    fd <- fromIntegral `liftM`
-	    throwErrnoIfMinus1Retry "fileTruncate"
- 	        (c_open file_cstr (fromIntegral flags) 0o666)
-    c_close fd
-  return ()
-
-#if defined(mingw32_TARGET_OS) || defined(__MINGW32__)
+#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
 closeFd :: Bool -> CInt -> IO CInt
 closeFd isStream fd 
   | isStream  = c_closesocket fd
@@ -142,7 +132,7 @@ foreign import stdcall unsafe "HsBase.h closesocket"
 
 fdGetMode :: Int -> IO IOMode
 fdGetMode fd = do
-#if defined(mingw32_TARGET_OS) || defined(__MINGW32__)
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
     -- XXX: this code is *BROKEN*, _setmode only deals with O_TEXT/O_BINARY
     flags1 <- throwErrnoIfMinus1Retry "fdGetMode" 
                 (c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
@@ -261,7 +251,7 @@ setCooked :: Int -> Bool -> IO ()
 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")
+   then ioError (ioe_unk_error "setCooked" "failed to set buffering")
    else return ()
 
 ioe_unk_error loc msg 
@@ -273,14 +263,14 @@ setEcho :: Int -> Bool -> IO ()
 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")
+   then ioError (ioe_unk_error "setEcho" "failed to set echoing")
    else return ()
 
 getEcho :: Int -> IO Bool
 getEcho fd = do
   r <- get_console_echo (fromIntegral fd)
   if (r == (-1))
-   then ioException (ioe_unk_error "getEcho" "failed to get echoing")
+   then ioError (ioe_unk_error "getEcho" "failed to get echoing")
    else return (r == 1)
 
 foreign import ccall unsafe "consUtils.h set_console_buffering__"
@@ -297,7 +287,7 @@ foreign import ccall unsafe "consUtils.h get_console_echo__"
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 
 setNonBlockingFD fd = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
@@ -387,10 +377,16 @@ foreign import ccall unsafe "HsBase.h umask"
 foreign import ccall unsafe "HsBase.h write" 
    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 
+foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
+   c_ftruncate :: CInt -> COff -> IO CInt
+
 foreign import ccall unsafe "HsBase.h unlink"
    c_unlink :: CString -> IO CInt
 
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+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"
    c_fcntl_read  :: CInt -> CInt -> IO CInt
 
@@ -403,9 +399,6 @@ foreign import ccall unsafe "HsBase.h fcntl"
 foreign import ccall unsafe "HsBase.h fork"
    c_fork :: IO CPid 
 
-foreign import ccall unsafe "HsBase.h getpid"
-   c_getpid :: IO CPid
-
 foreign import ccall unsafe "HsBase.h link"
    c_link :: CString -> CString -> IO CInt
 
@@ -505,7 +498,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
 
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 foreign import ccall unsafe "HsBase.h __hscore_s_issock" s_issock :: CMode -> Bool
 #else
 s_issock :: CMode -> Bool