Commit e1c6e73e authored by simonmar's avatar simonmar
Browse files

[project @ 2004-11-10 11:27:54 by simonmar]

Move the compatibility code for rawSystem from libraries/base into
ghc/lib/compat.
parent 845db818
{-# 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
......@@ -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
/*
* (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 <stdio.h>
#include <stdlib.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_ERRNO_H
#include <errno.h>
#endif
#ifdef HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
# ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
# else
# ifdef HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# include <time.h>
# endif
# endif
#include "HsFFI.h"
#if defined(mingw32_TARGET_OS)
#include <windows.h>
#endif
#ifdef HAVE_VFORK_H
#include <vfork.h>
#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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment