From: simonmar Date: Wed, 28 Aug 2002 13:59:19 +0000 (+0000) Subject: [project @ 2002-08-28 13:59:19 by simonmar] X-Git-Tag: nhc98-1-18-release~901 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=30c6b2c1e57c8724fac6c284ace227584bccfb0b;p=haskell-directory.git [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 --- 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 --- 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 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 +#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 + +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 +}