--- /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
+
+#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
+
--- /dev/null
+/*
+ * (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
projects / ghc-hetmet.git / commitdiff