From 7bd8a5cdd3aa22aa173a83216cc16ee5d947d33b Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 29 Jul 2007 21:56:17 +0000 Subject: Move System.Posix.Signals from base Also adds System.Posix.Process.Internals in order to make the deps work out. --- System/Posix/Process.hsc | 2 +- System/Posix/Process/Internals.hs | 13 + System/Posix/Signals.hs | 528 ++++++++++++++++++++++++++++++++++++++ cbits/execvpe.c | 175 +++++++++++++ include/execvpe.h | 25 ++ unix.cabal | 12 +- 6 files changed, 749 insertions(+), 6 deletions(-) create mode 100644 System/Posix/Process/Internals.hs create mode 100644 System/Posix/Signals.hs create mode 100644 cbits/execvpe.c create mode 100644 include/execvpe.h diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc index 9962d94..a6bbaa1 100644 --- a/System/Posix/Process.hsc +++ b/System/Posix/Process.hsc @@ -74,9 +74,9 @@ import System.IO import System.IO.Error import System.Exit import System.Posix.Error +import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) import System.Posix.Types import System.Posix.Signals -import System.Process.Internals ( pPrPr_disableITimers, c_execvpe ) import Control.Monad #ifdef __GLASGOW_HASKELL__ diff --git a/System/Posix/Process/Internals.hs b/System/Posix/Process/Internals.hs new file mode 100644 index 0000000..8639819 --- /dev/null +++ b/System/Posix/Process/Internals.hs @@ -0,0 +1,13 @@ + +module System.Posix.Process.Internals (pPrPr_disableITimers, c_execvpe) where + +import Foreign +import Foreign.C + +-- this function disables the itimer, which would otherwise cause confusing +-- signals to be sent to the new process. +foreign import ccall unsafe "pPrPr_disableITimers" + pPrPr_disableITimers :: IO () + +foreign import ccall unsafe "execvpe" + c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt diff --git a/System/Posix/Signals.hs b/System/Posix/Signals.hs new file mode 100644 index 0000000..1aa9dca --- /dev/null +++ b/System/Posix/Signals.hs @@ -0,0 +1,528 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Signals +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX signal support +-- +----------------------------------------------------------------------------- + +#include "HsBaseConfig.h" + +module System.Posix.Signals ( + -- * The Signal type + Signal, + + -- * Specific signals + nullSignal, + internalAbort, sigABRT, + realTimeAlarm, sigALRM, + busError, sigBUS, + processStatusChanged, sigCHLD, + continueProcess, sigCONT, + floatingPointException, sigFPE, + lostConnection, sigHUP, + illegalInstruction, sigILL, + keyboardSignal, sigINT, + killProcess, sigKILL, + openEndedPipe, sigPIPE, + keyboardTermination, sigQUIT, + segmentationViolation, sigSEGV, + softwareStop, sigSTOP, + softwareTermination, sigTERM, + keyboardStop, sigTSTP, + backgroundRead, sigTTIN, + backgroundWrite, sigTTOU, + userDefinedSignal1, sigUSR1, + userDefinedSignal2, sigUSR2, +#if CONST_SIGPOLL != -1 + pollableEvent, sigPOLL, +#endif + profilingTimerExpired, sigPROF, + badSystemCall, sigSYS, + breakpointTrap, sigTRAP, + urgentDataAvailable, sigURG, + virtualTimerExpired, sigVTALRM, + cpuTimeLimitExceeded, sigXCPU, + fileSizeLimitExceeded, sigXFSZ, + + -- * Sending signals + raiseSignal, + signalProcess, + signalProcessGroup, + +#ifdef __GLASGOW_HASKELL__ + -- * Handling signals + Handler(..), + installHandler, +#endif + + -- * Signal sets + SignalSet, + emptySignalSet, fullSignalSet, + addSignal, deleteSignal, inSignalSet, + + -- * The process signal mask + getSignalMask, setSignalMask, blockSignals, unblockSignals, + + -- * The alarm timer + scheduleAlarm, + + -- * Waiting for signals + getPendingSignals, +#ifndef cygwin32_HOST_OS + awaitSignal, +#endif + +#ifdef __GLASGOW_HASKELL__ + -- * The @NOCLDSTOP@ flag + setStoppedChildFlag, queryStoppedChildFlag, +#endif + + -- MISSING FUNCTIONALITY: + -- sigaction(), (inc. the sigaction structure + flags etc.) + -- the siginfo structure + -- sigaltstack() + -- sighold, sigignore, sigpause, sigrelse, sigset + -- siginterrupt + ) where + +import Foreign +import Foreign.C +import System.IO.Unsafe +import System.Posix.Types +import System.Posix.Internals + +#ifdef __GLASGOW_HASKELL__ +#include "Signals.h" +import GHC.Conc ( ensureIOManagerIsRunning ) +#endif + +-- ----------------------------------------------------------------------------- +-- Specific signals + +type Signal = CInt + +nullSignal :: Signal +nullSignal = 0 + +sigABRT :: CInt +sigABRT = CONST_SIGABRT +sigALRM :: CInt +sigALRM = CONST_SIGALRM +sigBUS :: CInt +sigBUS = CONST_SIGBUS +sigCHLD :: CInt +sigCHLD = CONST_SIGCHLD +sigCONT :: CInt +sigCONT = CONST_SIGCONT +sigFPE :: CInt +sigFPE = CONST_SIGFPE +sigHUP :: CInt +sigHUP = CONST_SIGHUP +sigILL :: CInt +sigILL = CONST_SIGILL +sigINT :: CInt +sigINT = CONST_SIGINT +sigKILL :: CInt +sigKILL = CONST_SIGKILL +sigPIPE :: CInt +sigPIPE = CONST_SIGPIPE +sigQUIT :: CInt +sigQUIT = CONST_SIGQUIT +sigSEGV :: CInt +sigSEGV = CONST_SIGSEGV +sigSTOP :: CInt +sigSTOP = CONST_SIGSTOP +sigTERM :: CInt +sigTERM = CONST_SIGTERM +sigTSTP :: CInt +sigTSTP = CONST_SIGTSTP +sigTTIN :: CInt +sigTTIN = CONST_SIGTTIN +sigTTOU :: CInt +sigTTOU = CONST_SIGTTOU +sigUSR1 :: CInt +sigUSR1 = CONST_SIGUSR1 +sigUSR2 :: CInt +sigUSR2 = CONST_SIGUSR2 +sigPOLL :: CInt +sigPOLL = CONST_SIGPOLL +sigPROF :: CInt +sigPROF = CONST_SIGPROF +sigSYS :: CInt +sigSYS = CONST_SIGSYS +sigTRAP :: CInt +sigTRAP = CONST_SIGTRAP +sigURG :: CInt +sigURG = CONST_SIGURG +sigVTALRM :: CInt +sigVTALRM = CONST_SIGVTALRM +sigXCPU :: CInt +sigXCPU = CONST_SIGXCPU +sigXFSZ :: CInt +sigXFSZ = CONST_SIGXFSZ + +internalAbort ::Signal +internalAbort = sigABRT + +realTimeAlarm :: Signal +realTimeAlarm = sigALRM + +busError :: Signal +busError = sigBUS + +processStatusChanged :: Signal +processStatusChanged = sigCHLD + +continueProcess :: Signal +continueProcess = sigCONT + +floatingPointException :: Signal +floatingPointException = sigFPE + +lostConnection :: Signal +lostConnection = sigHUP + +illegalInstruction :: Signal +illegalInstruction = sigILL + +keyboardSignal :: Signal +keyboardSignal = sigINT + +killProcess :: Signal +killProcess = sigKILL + +openEndedPipe :: Signal +openEndedPipe = sigPIPE + +keyboardTermination :: Signal +keyboardTermination = sigQUIT + +segmentationViolation :: Signal +segmentationViolation = sigSEGV + +softwareStop :: Signal +softwareStop = sigSTOP + +softwareTermination :: Signal +softwareTermination = sigTERM + +keyboardStop :: Signal +keyboardStop = sigTSTP + +backgroundRead :: Signal +backgroundRead = sigTTIN + +backgroundWrite :: Signal +backgroundWrite = sigTTOU + +userDefinedSignal1 :: Signal +userDefinedSignal1 = sigUSR1 + +userDefinedSignal2 :: Signal +userDefinedSignal2 = sigUSR2 + +#if CONST_SIGPOLL != -1 +pollableEvent :: Signal +pollableEvent = sigPOLL +#endif + +profilingTimerExpired :: Signal +profilingTimerExpired = sigPROF + +badSystemCall :: Signal +badSystemCall = sigSYS + +breakpointTrap :: Signal +breakpointTrap = sigTRAP + +urgentDataAvailable :: Signal +urgentDataAvailable = sigURG + +virtualTimerExpired :: Signal +virtualTimerExpired = sigVTALRM + +cpuTimeLimitExceeded :: Signal +cpuTimeLimitExceeded = sigXCPU + +fileSizeLimitExceeded :: Signal +fileSizeLimitExceeded = sigXFSZ + +-- ----------------------------------------------------------------------------- +-- Signal-related functions + +-- | @signalProcess int pid@ calls @kill@ to signal process @pid@ +-- with interrupt signal @int@. +signalProcess :: Signal -> ProcessID -> IO () +signalProcess sig pid + = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig) + +foreign import ccall unsafe "kill" + c_kill :: CPid -> CInt -> IO CInt + + +-- | @signalProcessGroup int pgid@ calls @kill@ to signal +-- all processes in group @pgid@ with interrupt signal @int@. +signalProcessGroup :: Signal -> ProcessGroupID -> IO () +signalProcessGroup sig pgid + = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig) + +foreign import ccall unsafe "killpg" + c_killpg :: CPid -> CInt -> IO CInt + +-- | @raiseSignal int@ calls @kill@ to signal the current process +-- with interrupt signal @int@. +raiseSignal :: Signal -> IO () +raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig) + +#if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS)) +foreign import ccall unsafe "genericRaise" + c_raise :: CInt -> IO CInt +#else +foreign import ccall unsafe "raise" + c_raise :: CInt -> IO CInt +#endif + +#ifdef __GLASGOW_HASKELL__ +data Handler = Default + | Ignore + -- not yet: | Hold + | Catch (IO ()) + | CatchOnce (IO ()) + +-- | @installHandler int handler iset@ calls @sigaction@ to install an +-- interrupt handler for signal @int@. If @handler@ is @Default@, +-- @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is +-- installed; if @handler@ is @Catch action@, a handler is installed +-- which will invoke @action@ in a new thread when (or shortly after) the +-- signal is received. +-- If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure +-- is set to @s@; otherwise it is cleared. The previously installed +-- signal handler for @int@ is returned +installHandler :: Signal + -> Handler + -> Maybe SignalSet -- ^ other signals to block + -> IO Handler -- ^ old handler + +#ifdef __PARALLEL_HASKELL__ +installHandler = + error "installHandler: not available for Parallel Haskell" +#else + +installHandler int handler maybe_mask = do + ensureIOManagerIsRunning -- for the threaded RTS + case maybe_mask of + Nothing -> install' nullPtr + Just (SignalSet x) -> withForeignPtr x $ install' + where + install' mask = + alloca $ \p_sp -> do + + rc <- case handler of + Default -> stg_sig_install int STG_SIG_DFL p_sp mask + Ignore -> stg_sig_install int STG_SIG_IGN p_sp mask + Catch m -> hinstall m p_sp mask int STG_SIG_HAN + CatchOnce m -> hinstall m p_sp mask int STG_SIG_RST + + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_ERR -> throwErrno "installHandler" + STG_SIG_HAN -> do + m <- peekHandler p_sp + return (Catch m) + STG_SIG_RST -> do + m <- peekHandler p_sp + return (CatchOnce m) + _other -> + error "internal error: System.Posix.Signals.installHandler" + + hinstall m p_sp mask int reset = do + sptr <- newStablePtr m + poke p_sp sptr + stg_sig_install int reset p_sp mask + + peekHandler p_sp = do + osptr <- peek p_sp + deRefStablePtr osptr + +foreign import ccall unsafe + stg_sig_install + :: CInt -- sig no. + -> CInt -- action code (STG_SIG_HAN etc.) + -> Ptr (StablePtr (IO ())) -- (in, out) Haskell handler + -> Ptr CSigset -- (in, out) blocked + -> IO CInt -- (ret) action code + +#endif /* !__PARALLEL_HASKELL__ */ +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- Alarms + +-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time +-- alarm at least @i@ seconds in the future. +scheduleAlarm :: Int -> IO Int +scheduleAlarm secs = do + r <- c_alarm (fromIntegral secs) + return (fromIntegral r) + +foreign import ccall unsafe "alarm" + c_alarm :: CUInt -> IO CUInt + +#ifdef __GLASGOW_HASKELL__ +-- ----------------------------------------------------------------------------- +-- The NOCLDSTOP flag + +foreign import ccall "&nocldstop" nocldstop :: Ptr Int + +-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when +-- installing new signal handlers. +setStoppedChildFlag :: Bool -> IO Bool +setStoppedChildFlag b = do + rc <- peek nocldstop + poke nocldstop $ fromEnum (not b) + return (rc == (0::Int)) + +-- | Queries the current state of the stopped child flag. +queryStoppedChildFlag :: IO Bool +queryStoppedChildFlag = do + rc <- peek nocldstop + return (rc == (0::Int)) +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- Manipulating signal sets + +newtype SignalSet = SignalSet (ForeignPtr CSigset) + +emptySignalSet :: SignalSet +emptySignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset) + return (SignalSet fp) + +fullSignalSet :: SignalSet +fullSignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset) + return (SignalSet fp) + +infixr `addSignal`, `deleteSignal` +addSignal :: Signal -> SignalSet -> SignalSet +addSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig) + return (SignalSet fp2) + +deleteSignal :: Signal -> SignalSet -> SignalSet +deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig) + return (SignalSet fp2) + +inSignalSet :: Signal -> SignalSet -> Bool +inSignalSet sig (SignalSet fp) = unsafePerformIO $ + withForeignPtr fp $ \p -> do + r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig) + return (r /= 0) + +-- | @getSignalMask@ calls @sigprocmask@ to determine the +-- set of interrupts which are currently being blocked. +getSignalMask :: IO SignalSet +getSignalMask = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p) + return (SignalSet fp) + +sigProcMask :: String -> CInt -> SignalSet -> IO () +sigProcMask fn how (SignalSet set) = + withForeignPtr set $ \p_set -> + throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr) + +-- | @setSignalMask mask@ calls @sigprocmask@ with +-- @SIG_SETMASK@ to block all interrupts in @mask@. +setSignalMask :: SignalSet -> IO () +setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set + +-- | @blockSignals mask@ calls @sigprocmask@ with +-- @SIG_BLOCK@ to add all interrupts in @mask@ to the +-- set of blocked interrupts. +blockSignals :: SignalSet -> IO () +blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set + +-- | @unblockSignals mask@ calls @sigprocmask@ with +-- @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the +-- set of blocked interrupts. +unblockSignals :: SignalSet -> IO () +unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set + +-- | @getPendingSignals@ calls @sigpending@ to obtain +-- the set of interrupts which have been received but are currently blocked. +getPendingSignals :: IO SignalSet +getPendingSignals = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p) + return (SignalSet fp) + +#ifndef cygwin32_HOST_OS + +-- | @awaitSignal iset@ suspends execution until an interrupt is received. +-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing +-- @s@ as the new signal mask before suspending execution; otherwise, it +-- calls @pause@. @awaitSignal@ returns on receipt of a signal. If you +-- have installed any signal handlers with @installHandler@, it may be +-- wise to call @yield@ directly after @awaitSignal@ to ensure that the +-- signal handler runs as promptly as possible. +awaitSignal :: Maybe SignalSet -> IO () +awaitSignal maybe_sigset = do + fp <- case maybe_sigset of + Nothing -> do SignalSet fp <- getSignalMask; return fp + Just (SignalSet fp) -> return fp + withForeignPtr fp $ \p -> do + c_sigsuspend p + return () + -- ignore the return value; according to the docs it can only ever be + -- (-1) with errno set to EINTR. + +foreign import ccall unsafe "sigsuspend" + c_sigsuspend :: Ptr CSigset -> IO CInt +#endif + +#ifdef __HUGS__ +foreign import ccall unsafe "sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import ccall unsafe "sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import ccall unsafe "sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#else +foreign import ccall unsafe "__hscore_sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import ccall unsafe "__hscore_sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#endif /* __HUGS__ */ + +foreign import ccall unsafe "sigpending" + c_sigpending :: Ptr CSigset -> IO CInt + diff --git a/cbits/execvpe.c b/cbits/execvpe.c new file mode 100644 index 0000000..160271c --- /dev/null +++ b/cbits/execvpe.c @@ -0,0 +1,175 @@ +/* ----------------------------------------------------------------------------- + (c) The University of Glasgow 1995-2004 + + Our low-level exec() variant. + -------------------------------------------------------------------------- */ +#include "execvpe.h" + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) /* to the end */ + +/* Evidently non-Posix. */ +/* #include "PosixSource.h" */ + +#include +#include +#include +#include +#include + +/* + * We want the search semantics of execvp, but we want to provide our + * own environment, like execve. The following copyright applies to + * this code, as it is a derivative of execvp: + *- + * Copyright (c) 1991 The Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +int +execvpe(char *name, char *const argv[], char **envp) +{ + register int lp, ln; + register char *p; + int eacces=0, etxtbsy=0; + char *bp, *cur, *path, *buf = 0; + + /* If it's an absolute or relative path name, it's easy. */ + if (strchr(name, '/')) { + bp = (char *) name; + cur = path = buf = NULL; + goto retry; + } + + /* Get the path we're searching. */ + if (!(path = getenv("PATH"))) { +#ifdef HAVE_CONFSTR + ln = confstr(_CS_PATH, NULL, 0); + if ((cur = path = malloc(ln + 1)) != NULL) { + path[0] = ':'; + (void) confstr (_CS_PATH, path + 1, ln); + } +#else + if ((cur = path = malloc(1 + 1)) != NULL) { + path[0] = ':'; + path[1] = '\0'; + } +#endif + } else + cur = path = strdup(path); + + if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL) + goto done; + + while (cur != NULL) { + p = cur; + if ((cur = strchr(cur, ':')) != NULL) + *cur++ = '\0'; + + /* + * It's a SHELL path -- double, leading and trailing colons mean the current + * directory. + */ + if (!*p) { + p = "."; + lp = 1; + } else + lp = strlen(p); + ln = strlen(name); + + memcpy(buf, p, lp); + buf[lp] = '/'; + memcpy(buf + lp + 1, name, ln); + buf[lp + ln + 1] = '\0'; + + retry: + (void) execve(bp, argv, envp); + switch (errno) { + case EACCES: + eacces = 1; + break; + case ENOENT: + break; + case ENOEXEC: + { + register size_t cnt; + register char **ap; + + for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt) + ; + if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) { + memcpy(ap + 2, argv + 1, cnt * sizeof(char *)); + + ap[0] = "sh"; + ap[1] = bp; + (void) execve("/bin/sh", ap, envp); + free(ap); + } + goto done; + } + case ETXTBSY: + if (etxtbsy < 3) + (void) sleep(++etxtbsy); + goto retry; + default: + goto done; + } + } + if (eacces) + errno = EACCES; + else if (!errno) + errno = ENOENT; + done: + if (path) + free(path); + if (buf) + free(buf); + return (-1); +} + + +/* Copied verbatim from ghc/lib/std/cbits/system.c. */ +void pPrPr_disableITimers (void) +{ +# 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 +} + +#endif diff --git a/include/execvpe.h b/include/execvpe.h new file mode 100644 index 0000000..676fc72 --- /dev/null +++ b/include/execvpe.h @@ -0,0 +1,25 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Interface for code in execvpe.c + ------------------------------------------------------------------------- */ + +#include "HsUnixConfig.h" +// Otherwise these clash with similar definitions from other packages: +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#include +#include +#if HAVE_SYS_WAIT_H +#include +#endif + +#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32) +extern int execvpe(char *name, char *const argv[], char **envp); +extern void pPrPr_disableITimers (void); +#endif + diff --git a/unix.cabal b/unix.cabal index 9f2267b..9f2cc8e 100644 --- a/unix.cabal +++ b/unix.cabal @@ -22,12 +22,14 @@ exposed-modules: System.Posix.Files System.Posix.IO System.Posix.Process + System.Posix.Process.Internals System.Posix.Resource System.Posix.Temp System.Posix.Terminal System.Posix.Time System.Posix.Unistd System.Posix.User + System.Posix.Signals System.Posix.Signals.Exts System.Posix.Semaphore System.Posix.SharedMem @@ -38,10 +40,10 @@ extra-source-files: extra-tmp-files: config.log config.status autom4te.cache unix.buildinfo include/HsUnixConfig.h -build-depends: base, directory, process -extensions: CPP +build-depends: base, directory +extensions: CPP, ForeignFunctionInterface include-dirs: include -includes: HsUnix.h +includes: HsUnix.h execvpe.h install-includes: - HsUnix.h HsUnixConfig.h -c-sources: cbits/HsUnix.c + HsUnix.h HsUnixConfig.h execvpe.h +c-sources: cbits/HsUnix.c cbits/execvpe.c -- cgit v1.2.3