+++ /dev/null
-{-# OPTIONS -cpp #-}
------------------------------------------------------------------------------
--- |
--- Module : Compat.Directory
--- Copyright : (c) The University of Glasgow 2001-2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Functions from System.Directory that aren't present in older versions
--- of that library.
---
------------------------------------------------------------------------------
-
-module Compat.Directory (
- getAppUserDataDirectory,
- copyFile,
- findExecutable,
- createDirectoryIfMissing
- ) where
-
-#include "../../includes/ghcconfig.h"
-
-import System.Environment (getEnv)
-import System.FilePath
-#if __GLASGOW_HASKELL__ > 600
-import Control.Exception ( bracket )
-import Control.Monad ( when )
-import Foreign.Marshal.Alloc ( allocaBytes )
-import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
-import System.IO.Error ( try )
-import GHC.IOBase ( IOException(..) )
-#if defined(mingw32_HOST_OS)
-import GHC.IOBase ( IOErrorType(..) )
-#endif
-#else
-import System.IO ( try )
-#endif
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-import Foreign
-import Foreign.C
-#endif
-import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
-
-getAppUserDataDirectory :: String -> IO FilePath
-getAppUserDataDirectory appName = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
- when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
- s <- peekCString pPath
- return (s++'\\':appName)
-#else
- path <- getEnv "HOME"
- return (path++'/':'.':appName)
-#endif
-
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-foreign import ccall unsafe "directory.h __hscore_getFolderPath"
- c_SHGetFolderPath :: Ptr ()
- -> CInt
- -> Ptr ()
- -> CInt
- -> CString
- -> IO CInt
-
--- __compat_long_path_size defined in cbits/directory.c
-foreign import ccall unsafe "directory.h __compat_long_path_size"
- long_path_size :: Int
-
-foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
-
-raiseUnsupported loc =
- ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
-#endif
-
-
-copyFile :: FilePath -> FilePath -> IO ()
-copyFile fromFPath toFPath =
-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
- do readFile fromFPath >>= writeFile toFPath
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()
-#else
- (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer -> do
- copyContents hFrom hTo buffer
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()) `catch` (ioError . changeFunName)
- where
- bufferSize = 1024
-
- changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
-
- copyContents hFrom hTo buffer = do
- count <- hGetBuf hFrom buffer bufferSize
- when (count > 0) $ do
- hPutBuf hTo buffer count
- copyContents hFrom hTo buffer
-#endif
-
--- | Given an executable file name, searches for such file
--- in the directories listed in system PATH. The returned value
--- is the path to the found executable or Nothing if there isn't
--- such executable. For example (findExecutable \"ghc\")
--- gives you the path to GHC.
-findExecutable :: String -> IO (Maybe FilePath)
-findExecutable binary =
-#if defined(mingw32_HOST_OS)
- withCString binary $ \c_binary ->
- withCString ('.':exeExtension) $ \c_ext ->
- allocaBytes long_path_size $ \pOutPath ->
- alloca $ \ppFilePart -> do
- res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
- if res > 0 && res < fromIntegral long_path_size
- then do fpath <- peekCString pOutPath
- return (Just fpath)
- else return Nothing
-
-foreign import stdcall unsafe "SearchPathA"
- c_SearchPath :: CString
- -> CString
- -> CString
- -> CInt
- -> CString
- -> Ptr CString
- -> IO CInt
-#else
- do
- path <- getEnv "PATH"
- search (splitSearchPath path)
- where
- fileName = binary <.> exeExtension
-
- search :: [FilePath] -> IO (Maybe FilePath)
- search [] = return Nothing
- search (d:ds) = do
- let path = d </> fileName
- b <- doesFileExist path
- if b then return (Just path)
- else search ds
-#endif
-
--- ToDo: This should be determined via autoconf (AC_EXEEXT)
--- | Extension for executable files
--- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
-exeExtension :: String
-#ifdef mingw32_HOST_OS
-exeExtension = "exe"
-#else
-exeExtension = ""
-#endif
-
--- | @'createDirectoryIfMissing' parents dir@ creates a new directory
--- @dir@ if it doesn\'t exist. If the first argument is 'True'
--- the function will also create all parent directories if they are missing.
-createDirectoryIfMissing :: Bool -- ^ Create its parents too?
- -> FilePath -- ^ The path to the directory you want to make
- -> IO ()
-createDirectoryIfMissing parents file = do
- b <- doesDirectoryExist file
- case (b,parents, file) of
- (_, _, "") -> return ()
- (True, _, _) -> return ()
- (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
- (_, False, _) -> createDirectory file
- where mkParents = scanl1 (</>) . splitDirectories . normalise
+++ /dev/null
-{-# OPTIONS -cpp #-}
------------------------------------------------------------------------------
--- |
--- Module : Compat.RawSystem
--- Copyright : (c) The University of Glasgow 2001-2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- This is an implementation of rawSystem for use on older versions of GHC
--- which had missing or buggy implementations of this function.
---
------------------------------------------------------------------------------
-
-module Compat.RawSystem (rawSystem) where
-
-#include "../../includes/ghcconfig.h"
-
-#if __GLASGOW_HASKELL__ >= 603
-
-import System.Cmd (rawSystem)
-
-#else /* to end of file */
-
-import System.Exit
-import Foreign
-import Foreign.C
-
-{- |
-The computation @'rawSystem' cmd args@ runs the operating system command
-whose file name is @cmd@, passing it the arguments @args@. It
-bypasses the shell, so that @cmd@ should see precisely the argument
-strings @args@, with no funny escaping or shell meta-syntax expansion.
-(Unix users will recognise this behaviour
-as @execvp@, and indeed that's how it's implemented.)
-It will therefore behave more portably between operating systems than 'system'.
-
-The return codes are the same as for 'system'.
--}
-
-rawSystem :: FilePath -> [String] -> IO ExitCode
-
-{- -------------------------------------------------------------------------
- IMPORTANT IMPLEMENTATION NOTES
- (see also libraries/base/cbits/rawSystem.c)
-
-On Unix, rawSystem is easy to implement: use execvp.
-
-On Windows it's more tricky. We use CreateProcess, passing a single
-command-line string (lpCommandLine) as its argument. (CreateProcess
-is well documented on http://msdn.microsoft/com.)
-
- - It parses the beginning of the string to find the command. If the
- file name has embedded spaces, it must be quoted, using double
- quotes thus
- "foo\this that\cmd" arg1 arg2
-
- - The invoked command can in turn access the entire lpCommandLine string,
- and the C runtime does indeed do so, parsing it to generate the
- traditional argument vector argv[0], argv[1], etc. It does this
- using a complex and arcane set of rules which are described here:
-
- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
-
- (if this URL stops working, you might be able to find it by
- searching for "Parsing C Command-Line Arguments" on MSDN. Also,
- the code in the Microsoft C runtime that does this translation
- is shipped with VC++).
-
-
-Our goal in rawSystem is to take a command filename and list of
-arguments, and construct a string which inverts the translatsions
-described above, such that the program at the other end sees exactly
-the same arguments in its argv[] that we passed to rawSystem.
-
-This inverse translation is implemented by 'translate' below.
-
-Here are some pages that give informations on Windows-related
-limitations and deviations from Unix conventions:
-
- http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
- Command lines and environment variables effectively limited to 8191
- characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
- Command-line substitution under Windows XP. IIRC these facilities (or at
- least a large subset of them) are available on Win NT and 2000. Some
- might be available on Win 9x.
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
- How CMD.EXE processes command lines.
-
-
-Note: CreateProcess does have a separate argument (lpApplicationName)
-with which you can specify the command, but we have to slap the
-command into lpCommandLine anyway, so that argv[0] is what a C program
-expects (namely the application name). So it seems simpler to just
-use lpCommandLine alone, which CreateProcess supports.
-
------------------------------------------------------------------------------ -}
-
-#ifndef mingw32_HOST_OS
-
-rawSystem cmd args =
- withCString cmd $ \pcmd ->
- withMany withCString (cmd:args) $ \cstrs ->
- withArray0 nullPtr cstrs $ \arr -> do
- status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-foreign import ccall unsafe "rawSystem"
- c_rawSystem :: CString -> Ptr CString -> IO Int
-
-#else
-
--- On Windows, the command line is passed to the operating system as
--- a single string. Command-line parsing is done by the executable
--- itself.
-rawSystem cmd args = do
- -- NOTE: 'cmd' is assumed to contain the application to run _only_,
- -- as it'll be quoted surrounded in quotes here.
- let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
- withCString cmdline $ \pcmdline -> do
- status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-translate :: String -> String
-translate str@('"':_) = str -- already escaped.
- -- ToDo: this case is wrong. It is only here because we
- -- abuse the system in GHC's SysTools by putting arguments into
- -- the command name; at some point we should fix it up and remove
- -- the case above.
-translate str = '"' : snd (foldr escape (True,"\"") str)
- where escape '"' (b, str) = (True, '\\' : '"' : str)
- escape '\\' (True, str) = (True, '\\' : '\\' : str)
- escape '\\' (False, str) = (False, '\\' : str)
- escape c (b, str) = (False, c : str)
- -- See long comment above for what this function is trying to do.
- --
- -- The Bool passed back along the string is True iff the
- -- rest of the string is a sequence of backslashes followed by
- -- a double quote.
-
-foreign import ccall unsafe "rawSystem"
- c_rawSystem :: CString -> IO Int
-
-#endif
-
-#endif
-
# This is horrible. We ought to be able to omit the entire directory
# from mkDependHS.
SRC_MKDEPENDHS_OPTS += \
- -optdep--exclude-module=Compat.RawSystem \
- -optdep--exclude-module=Compat.Directory \
-optdep--exclude-module=Compat.Unicode \
-optdep--exclude-module=Distribution.Compat.FilePath \
-optdep--exclude-module=Distribution.Compat.ReadP \
-optdep--exclude-module=System.FilePath \
-optdep--exclude-module=System.FilePath.Posix \
-optdep--exclude-module=System.FilePath.Windows \
- -optdep--exclude-module=System.Directory.Internals \
-optdep--exclude-module=Trace.Hpc.Mix \
-optdep--exclude-module=Trace.Hpc.Tix \
-optdep--exclude-module=Trace.Hpc.Util
import Data.Array
import System.IO (FilePath)
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-import Compat.Directory ( createDirectoryIfMissing )
-#else
import System.Directory ( createDirectoryIfMissing )
-#endif
import Trace.Hpc.Mix
import Trace.Hpc.Util
import Panic
import Outputable
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-import Compat.Directory ( getAppUserDataDirectory )
-#endif
-
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.Package
import CString ( CString, peekCString )
#endif
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
--- rawSystem comes from libghccompat.a in stage1
-import Compat.RawSystem ( rawSystem )
-import System.Cmd ( system )
-import GHC.IOBase ( IOErrorType(..) )
-#else
import System.Process ( runInteractiveProcess, getProcessExitCode )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
import FastString ( mkFastString )
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
-#endif
\end{code}
import Distribution.Package
import Distribution.Version
import System.FilePath
-
-#ifdef USING_COMPAT
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
-#else
-import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import System.Cmd ( rawSystem )
-#endif
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import Prelude
#endif
#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
-#ifdef USING_COMPAT
-import Compat.RawSystem ( rawSystem )
-#else
import System.Cmd ( rawSystem )
-#endif
#define HAVE_rawSystem
#elif __NHC__ >= 117
import System.Cmd ( rawSystem )
UseGhcForCc = YES
SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
-# This causes libghccompat.a to be used:
-include $(GHC_COMPAT_DIR)/compat.mk
-
-# This is required because libghccompat.a must be built with
-# $(GhcHcOpts) because it is linked to the compiler, and hence
-# we must also build with $(GhcHcOpts) here:
-SRC_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts)
SRC_HC_OPTS += -Wall
RUNHASKELL_PROG = runhaskell$(exeext)
import System.Directory ( removeFile )
import Control.Exception ( bracket )
import System.Directory ( findExecutable, getTemporaryDirectory )
-
-#ifdef USING_COMPAT
-import Compat.RawSystem ( rawSystem )
-#else
import System.Cmd ( rawSystem )
-#endif
main :: IO ()
main = do
projects / ghc-hetmet.git / commitdiff