X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=a543f2b1f6c27454f635fef63d0817d34eba3396;hb=ca4fc090b0ad583d07017a69430227ce32684ac0;hp=9560c26b9b8526a4732331c6a8f6ba07f4beee0c;hpb=ee7be4593b1b17d4ef45c37963b8b19d53865ab6;p=ghc-base.git

diff --git a/System/IO.hs b/System/IO.hs
index 9560c26..a543f2b 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -151,6 +151,7 @@ module System.IO (
     hPutBuf,                   -- :: Handle -> Ptr a -> Int -> IO ()
     hGetBuf,                   -- :: Handle -> Ptr a -> Int -> IO Int
 #if !defined(__NHC__) && !defined(__HUGS__)
+    hGetBufSome,               -- :: Handle -> Ptr a -> Int -> IO Int
     hPutBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int
     hGetBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int
 #endif
@@ -159,6 +160,8 @@ module System.IO (
 
     openTempFile,
     openBinaryTempFile,
+    openTempFileWithDefaultPermissions,
+    openBinaryTempFileWithDefaultPermissions,
 
 #if !defined(__NHC__) && !defined(__HUGS__)
     -- * Unicode encoding\/decoding
@@ -169,9 +172,9 @@ module System.IO (
     --
     -- The default 'TextEncoding' is the same as the default encoding
     -- on your system, which is also available as 'localeEncoding'.
-    -- (GHC note: on Windows, currently 'localeEncoding' is always
-    -- 'latin1'; there is no support for encoding and decoding using
-    -- the ANSI code page).
+    -- (GHC note: on Windows, we currently do not support double-byte
+    -- encodings; if the console\'s code page is unsupported, then
+    -- 'localeEncoding' will be 'latin1'.)
     --
     -- Encoding and decoding errors are always detected and reported,
     -- except during lazy I/O ('hGetContents', 'getContents', and
@@ -179,11 +182,12 @@ module System.IO (
     -- termination of the character stream, as with other I/O errors.
 
     hSetEncoding, 
+    hGetEncoding,
 
     -- ** Unicode encodings
     TextEncoding, 
     latin1,
-    utf8, 
+    utf8, utf8_bom,
     utf16, utf16le, utf16be,
     utf32, utf32le, utf32be, 
     localeEncoding,
@@ -226,18 +230,21 @@ import Data.Maybe
 import Foreign.C.Error
 import Foreign.C.Types
 import System.Posix.Internals
+import System.Posix.Types
 #endif
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
+import GHC.Real
 import GHC.IO hiding ( onException )
 import GHC.IO.IOMode
 import GHC.IO.Handle.FD
+import qualified GHC.IO.FD as FD
 import GHC.IO.Handle
+import GHC.IO.Handle.Text ( hGetBufSome )
 import GHC.IORef
 import GHC.IO.Exception ( userError )
 import GHC.IO.Encoding
-import GHC.Exception
 import GHC.Num
 import Text.Read
 import GHC.Show
@@ -465,6 +472,8 @@ fixIO k = do
 -- Assume a unix platform, where text and binary I/O are identical.
 openBinaryFile = openFile
 hSetBinaryMode _ _ = return ()
+
+type CMode = Int
 #endif
 
 -- | The function creates a temporary file in ReadWrite mode.
@@ -487,14 +496,29 @@ openTempFile :: FilePath   -- ^ Directory in which to create the file
                            -- the created file will be \"fooXXX.ext\" where XXX is some
                            -- random number.
              -> IO (FilePath, Handle)
-openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False
+openTempFile tmp_dir template
+    = openTempFile' "openTempFile" tmp_dir template False 0o600
 
 -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
 openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
-
-openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
-openTempFile' loc tmp_dir template binary = do
+openBinaryTempFile tmp_dir template
+    = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
+
+-- | Like 'openTempFile', but uses the default file permissions
+openTempFileWithDefaultPermissions :: FilePath -> String
+                                   -> IO (FilePath, Handle)
+openTempFileWithDefaultPermissions tmp_dir template
+    = openTempFile' "openBinaryTempFile" tmp_dir template False 0o666
+
+-- | Like 'openBinaryTempFile', but uses the default file permissions
+openBinaryTempFileWithDefaultPermissions :: FilePath -> String
+                                         -> IO (FilePath, Handle)
+openBinaryTempFileWithDefaultPermissions tmp_dir template
+    = openTempFile' "openBinaryTempFile" tmp_dir template True 0o666
+
+openTempFile' :: String -> FilePath -> String -> Bool -> CMode
+              -> IO (FilePath, Handle)
+openTempFile' loc tmp_dir template binary mode = do
   pid <- c_getpid
   findTempName pid
   where
@@ -525,13 +549,13 @@ openTempFile' loc tmp_dir template binary = do
     oflags = oflags1 .|. binary_flags
 #endif
 
-#ifdef __NHC__
+#if defined(__NHC__)
     findTempName x = do h <- openFile filepath ReadWriteMode
                         return (filepath, h)
-#else
+#elif defined(__GLASGOW_HASKELL__)
     findTempName x = do
       fd <- withFilePath filepath $ \ f ->
-              c_open f oflags 0o600
+              c_open f oflags mode
       if fd < 0
        then do
          errno <- getErrno
@@ -539,12 +563,20 @@ openTempFile' loc tmp_dir template binary = do
            then findTempName (x+1)
            else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
        else do
-         -- XXX We want to tell fdToHandle what the filepath is,
-         -- as any exceptions etc will only be able to report the
-         -- fd currently
+
+         (fD,fd_type) <- FD.mkFD (fromIntegral fd) ReadWriteMode Nothing{-no stat-}
+                              False{-is_socket-} 
+                              True{-is_nonblock-}
+
+         h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-}
+                           (Just localeEncoding)
+
+         return (filepath, h)
+#else
          h <- fdToHandle fd `onException` c_close fd
          return (filepath, h)
 #endif
+
       where
         filename        = prefix ++ show x ++ suffix
         filepath        = tmp_dir `combine` filename