From e1c6e73ee529c1fa95ca85e6999319949a8f2991 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 10 Nov 2004 11:27:54 +0000 Subject: [PATCH] [project @ 2004-11-10 11:27:54 by simonmar] Move the compatibility code for rawSystem from libraries/base into ghc/lib/compat. --- ghc/lib/compat/Compat/RawSystem.hs | 154 ++++++++++++++++++++++++++++++++++++ ghc/lib/compat/Makefile | 31 +++++++- ghc/lib/compat/cbits/rawSystem.c | 149 ++++++++++++++++++++++++++++++++++ 3 files changed, 332 insertions(+), 2 deletions(-) create mode 100644 ghc/lib/compat/Compat/RawSystem.hs create mode 100644 ghc/lib/compat/cbits/rawSystem.c diff --git a/ghc/lib/compat/Compat/RawSystem.hs b/ghc/lib/compat/Compat/RawSystem.hs new file mode 100644 index 0000000..2d88c29 --- /dev/null +++ b/ghc/lib/compat/Compat/RawSystem.hs @@ -0,0 +1,154 @@ +{-# 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 + +#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_TARGET_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 + diff --git a/ghc/lib/compat/Makefile b/ghc/lib/compat/Makefile index c3f080b..081ea78 100644 --- a/ghc/lib/compat/Makefile +++ b/ghc/lib/compat/Makefile @@ -15,11 +15,38 @@ include $(TOP)/mk/boilerplate.mk ALL_DIRS = \ Data \ + Compat \ Distribution \ - Distribution/Compat + Distribution/Compat \ + cbits LIBRARY = libghccompat.a -SRC_HC_OPTS += -I$(FPTOOLS_TOP)/libraries -fglasgow-exts +# Just to silence warnings +MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) + +UseGhcForCc = YES + +ghc_603_plus = $(shell if (test $(GhcCanonVersion) -ge 603); then echo YES; else echo NO; fi) + +ifeq "$(ghc_603_plus)" "YES" +# These modules are all provided in GHC 6.3+ +EXCLUDED_SRCS += \ + Data/Version.hs \ + Distribution/Compat/Error.hs \ + Distribution/Compat/ReadP.hs \ + Distribution/Extension.hs \ + Distribution/InstalledPackageInfo.hs \ + Distribution/License.hs \ + Distribution/Package.hs \ + Distribution/ParseUtils.hs \ + Distribution/Setup.hs \ + Distribution/Version.hs +endif + +# Make the #includes in the stubs independent of the current location +SRC_HC_OPTS += -I$(FPTOOLS_TOP)/libraries + +SRC_HC_OPTS += -fglasgow-exts include $(TOP)/mk/target.mk diff --git a/ghc/lib/compat/cbits/rawSystem.c b/ghc/lib/compat/cbits/rawSystem.c new file mode 100644 index 0000000..7af7747 --- /dev/null +++ b/ghc/lib/compat/cbits/rawSystem.c @@ -0,0 +1,149 @@ +/* + * (c) The University of Glasgow 1994-2004 + * + * WARNING: this file is here for backwards compatibility only. It is + * not included as part of the base package, but is #included into the + * compiler and the runghc utility when building either of these with + * an old version of GHC. + * + * shell-less system Runtime Support (see System.Cmd.rawSystem). + */ + +/* The itimer stuff in this module is non-posix */ +/* #include "PosixSource.h" */ + +/* This ifdef is required because this source might be compiled by an + * external compiler. See ghc/utils/runghc/rawSystem.c for example. + */ +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ < 603 +#include "config.h" +#else +#include "ghcconfig.h" +#endif +#endif + +#include +#include + +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_ERRNO_H +#include +#endif +#ifdef HAVE_SYS_WAIT_H +#include +#endif + +# ifdef TIME_WITH_SYS_TIME +# include +# include +# else +# ifdef HAVE_SYS_TIME_H +# include +# else +# include +# endif +# endif + +#include "HsFFI.h" + +#if defined(mingw32_TARGET_OS) +#include +#endif + +#ifdef HAVE_VFORK_H +#include +#endif + +#ifdef HAVE_VFORK +#define fork vfork +#endif + +#if defined(mingw32_TARGET_OS) +/* -------------------- WINDOWS VERSION --------------------- */ + +HsInt +rawSystem(HsAddr cmd) +{ + STARTUPINFO sInfo; + PROCESS_INFORMATION pInfo; + DWORD retCode; + + ZeroMemory(&sInfo, sizeof(sInfo)); + sInfo.cb = sizeof(sInfo); + + if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, 0, NULL, NULL, &sInfo, &pInfo)) { + /* The 'TRUE' says that the created process should share + handles with the current process. This is vital to ensure + that error messages sent to stderr actually appear on the screen. + Since we are going to wait for the process to terminate anyway, + there is no problem with such sharing. */ + + errno = EINVAL; // ToDo: wrong, caller should use GetLastError() + return -1; + } + WaitForSingleObject(pInfo.hProcess, INFINITE); + if (GetExitCodeProcess(pInfo.hProcess, &retCode) == 0) { + errno = EINVAL; // ToDo: wrong, caller should use GetLastError() + return -1; + } + + CloseHandle(pInfo.hProcess); + CloseHandle(pInfo.hThread); + return retCode; +} + +#else +/* -------------------- UNIX VERSION --------------------- */ + +HsInt +rawSystem(HsAddr cmd, HsAddr args) +{ + int pid; + int wstat; + + switch(pid = fork()) { + case -1: + { + return -1; + } + case 0: + { +#ifdef HAVE_SETITIMER + /* Reset the itimers in the child, so it doesn't get plagued + * by SIGVTALRM interrupts. + */ + struct timeval tv_null = { 0, 0 }; + struct itimerval itv; + itv.it_interval = tv_null; + itv.it_value = tv_null; + setitimer(ITIMER_REAL, &itv, NULL); + setitimer(ITIMER_VIRTUAL, &itv, NULL); + setitimer(ITIMER_PROF, &itv, NULL); +#endif + + /* the child */ + execvp(cmd, args); + _exit(127); + } + } + + while (waitpid(pid, &wstat, 0) < 0) { + if (errno != EINTR) { + return -1; + } + } + + if (WIFEXITED(wstat)) + return WEXITSTATUS(wstat); + else if (WIFSIGNALED(wstat)) { + errno = EINTR; + } + else { + /* This should never happen */ + } + return -1; +} +#endif -- 1.7.10.4