[project @ 2002-08-28 13:59:19 by simonmar]

- Move rawSystem from SystemExts to System.Cmd.
- Move withArgv and withProgName from SystemExts to System.Environment

These functions are still exported by SystemExts for compatibility.

diff --git a/System/Cmd.hs b/System/Cmd.hs
index ff9a316..b4bb038 100644 (file)
--- a/System/Cmd.hs
+++ b/System/Cmd.hs
@@ -13,7 +13,8 @@
 -----------------------------------------------------------------------------
 
 module System.Cmd
-    ( system        -- :: String -> IO ExitCode
+    ( system,        -- :: String -> IO ExitCode
+      rawSystem,     -- :: String -> IO ExitCode
     ) where
 
 import Prelude
@@ -66,3 +67,20 @@ system cmd =
 
 foreign import ccall unsafe "systemCmd" primSystem :: CString -> IO Int
 #endif  /* __HUGS__ */
+
+{- | 
+The same as 'system', but bypasses the shell.  Will behave more portably between
+systems, because there is no interpretation of shell metasyntax.
+-}
+
+rawSystem :: String -> IO ExitCode
+rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
+rawSystem cmd =
+  withCString cmd $ \s -> do
+    status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
+    case status of
+        0  -> return ExitSuccess
+        n  -> return (ExitFailure n)
+
+foreign import ccall unsafe "rawSystemCmd" primRawSystem :: CString -> IO Int
+

diff --git a/System/Environment.hs b/System/Environment.hs
index 4e9efb6..02c11a7 100644 (file)
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -14,12 +14,15 @@
 
 module System.Environment
     ( 
-      getArgs      -- :: IO [String]
-    , getProgName   -- :: IO String
-    , getEnv        -- :: String -> IO String
+      getArgs,      -- :: IO [String]
+      getProgName,   -- :: IO String
+      getEnv,        -- :: String -> IO String
+      withArgs,
+      withProgName,
   ) where
 
 import Prelude
+import System.IO       ( bracket )
 
 #ifndef __HUGS__
 import Foreign
@@ -112,3 +115,43 @@ getEnv name =
 foreign import ccall unsafe "getenv"
    c_getenv :: CString -> IO (Ptr CChar)
 #endif  /* __HUGS__ */
+
+{-|
+@withArgs args act@ - while executing action @act@, have 'System.getArgs'
+return @args@.
+-}
+withArgs xs act = do
+   p <- System.Environment.getProgName
+   withArgv (p:xs) act
+
+{-|
+@withProgName name act@ - while executing action @act@, have 'System.getProgName'return @name@.
+-}
+withProgName nm act = do
+   xs <- System.Environment.getArgs
+   withArgv (nm:xs) act
+
+-- Worker routine which marshals and replaces an argv vector for
+-- the duration of an action.
+
+withArgv new_args act = do
+  pName <- System.Environment.getProgName
+  existing_args <- System.Environment.getArgs
+  bracket (setArgs new_args) 
+         (\argv -> do setArgs (pName:existing_args); freeArgv argv)
+         (const act)
+
+freeArgv :: Ptr CString -> IO ()
+freeArgv argv = do
+  size <- lengthArray0 nullPtr argv
+  sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]
+  free argv
+
+setArgs :: [String] -> IO (Ptr CString)
+setArgs argv = do
+  vs <- mapM newCString argv >>= newArray0 nullPtr
+  setArgsPrim (length argv) vs
+  return vs
+
+foreign import ccall unsafe "setProgArgv" 
+  setArgsPrim  :: Int -> Ptr CString -> IO ()

diff --git a/cbits/rawSystem.c b/cbits/rawSystem.c
new file mode 100644 (file)
index 0000000..6402af4
--- /dev/null
+++ b/cbits/rawSystem.c
@@ -0,0 +1,122 @@
+/* 
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: rawSystem.c,v 1.1 2002/08/28 13:59:19 simonmar Exp $
+ *
+ * shell-less system Runtime Support
+ */
+
+/* The itimer stuff in this module is non-posix */
+/* #include "PosixSource.h" */
+
+#include "config.h"
+
+#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
+
+HsInt
+rawSystemCmd(HsAddr cmd)
+{
+  /* -------------------- WINDOWS VERSION --------------------- */
+#if defined(mingw32_TARGET_OS)
+  STARTUPINFO sInfo;
+  PROCESS_INFORMATION pInfo;
+  DWORD retCode;
+
+  sInfo.cb              = sizeof(STARTUPINFO);
+  sInfo.lpReserved      = NULL;
+  sInfo.lpReserved2     = NULL;
+  sInfo.cbReserved2     = 0;
+  sInfo.lpDesktop       = NULL;
+  sInfo.lpTitle         = NULL;
+  sInfo.dwFlags         = 0;
+
+  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. */
+
+    return -1;
+  WaitForSingleObject(pInfo.hProcess, INFINITE);
+  if (GetExitCodeProcess(pInfo.hProcess, &retCode) == 0) return -1;
+  CloseHandle(pInfo.hProcess);
+  CloseHandle(pInfo.hThread);
+  return retCode;
+
+#else
+  /* -------------------- UNIX VERSION --------------------- */
+    int pid;
+    int wstat;
+
+    switch(pid = fork()) {
+    case -1:
+       if (errno != EINTR) {
+           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 */
+       execl(cmd, NULL);
+       _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
+}