X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/34b6177b15201248a63305f835275c672bcb0f25..4247d8e34e410032a8a1f1fe036201c2be431090:/libguile/simpos.c diff --git a/libguile/simpos.c b/libguile/simpos.c index 8c4dda542..70058285a 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,28 +1,32 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009, + * 2010, 2012, 2013, 2014 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ -#if HAVE_CONFIG_H +#ifdef HAVE_CONFIG_H # include #endif #include +#include /* for SIG constants */ #include /* for getenv */ +#include #include "libguile/_scm.h" @@ -31,20 +35,28 @@ #include "libguile/validate.h" #include "libguile/simpos.h" +#include "libguile/dynwind.h" #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include +#if HAVE_SYS_WAIT_H +# include +#endif + +#ifdef __MINGW32__ +# include /* for spawnvp and friends */ #endif +#include "posix.h" + extern int system(); #ifdef HAVE_SYSTEM -SCM_DEFINE (scm_system, "system", 0, 1, 0, +SCM_DEFINE (scm_system, "system", 0, 1, 0, (SCM cmd), "Execute @var{cmd} using the operating system's \"command\n" "processor\". Under Unix this is usually the default shell\n" @@ -56,57 +68,195 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, "indicating whether the command processor is available.") #define FUNC_NAME s_scm_system { - int rv; - + int rv, eno; + char *c_cmd; + if (SCM_UNBNDP (cmd)) { rv = system (NULL); - return SCM_BOOL(rv); - } + return scm_from_bool(rv); + } SCM_VALIDATE_STRING (1, cmd); - SCM_DEFER_INTS; errno = 0; - rv = system (SCM_STRING_CHARS (cmd)); + c_cmd = scm_to_locale_string (cmd); + rv = system (c_cmd); + eno = errno; free (c_cmd); errno = eno; if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; - SCM_ALLOW_INTS; - return SCM_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME #endif /* HAVE_SYSTEM */ + +#ifdef HAVE_SYSTEM + +SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, + (SCM args), +"Execute the command indicated by @var{args}. The first element must\n" +"be a string indicating the command to be executed, and the remaining\n" +"items must be strings representing each of the arguments to that\n" +"command.\n" +"\n" +"This function returns the exit status of the command as provided by\n" +"@code{waitpid}. This value can be handled with @code{status:exit-val}\n" +"and the related functions.\n" +"\n" +"@code{system*} is similar to @code{system}, but accepts only one\n" +"string per-argument, and performs no shell interpretation. The\n" +"command is executed using fork and execlp. Accordingly this function\n" +"may be safer than @code{system} in situations where shell\n" +"interpretation is not required.\n" +"\n" +"Example: (system* \"echo\" \"foo\" \"bar\")") +#define FUNC_NAME s_scm_system_star +{ + if (scm_is_null (args)) + SCM_WRONG_NUM_ARGS (); + + if (scm_is_pair (args)) + { + SCM oldint; + SCM sig_ign; + SCM sigint; + /* SIGQUIT is undefined on MS-Windows. */ +#ifdef SIGQUIT + SCM oldquit; + SCM sigquit; +#endif +#ifdef HAVE_FORK + int pid; +#else + int status; +#endif + char **execargv; + + /* allocate before fork */ + execargv = scm_i_allocate_string_pointers (args); + + /* make sure the child can't kill us (as per normal system call) */ + sig_ign = scm_from_ulong ((unsigned long) SIG_IGN); + sigint = scm_from_int (SIGINT); + oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); +#ifdef SIGQUIT + sigquit = scm_from_int (SIGQUIT); + oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); +#endif + +#ifdef HAVE_FORK + pid = fork (); + if (pid == 0) + { + /* child */ + execvp (execargv[0], execargv); + + /* Something went wrong. */ + fprintf (stderr, "In execvp of %s: %s\n", + execargv[0], strerror (errno)); + + /* Exit directly instead of throwing, because otherwise this + process may keep on running. Use exit status 127, like + shells in this case, as per POSIX + . */ + _exit (127); + } + else + { + /* parent */ + int wait_result, status; + + if (pid == -1) + SCM_SYSERROR; + + SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); + if (wait_result == -1) + SCM_SYSERROR; + scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); + scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); + + return scm_from_int (status); + } +#else /* !HAVE_FORK */ + status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv); + scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); +#ifdef SIGQUIT + scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); +#endif + + return scm_from_int (status); +#endif /* !HAVE_FORK */ + } + else + SCM_WRONG_TYPE_ARG (1, args); +} +#undef FUNC_NAME +#endif /* HAVE_SYSTEM */ + + SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, (SCM nam), - "Looks up the string @var{name} in the current environment. The return\n" + "Looks up the string @var{nam} in the current environment. The return\n" "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n" "found, in which case the string @code{VALUE} is returned.") #define FUNC_NAME s_scm_getenv { char *val; - SCM_VALIDATE_STRING (1, nam); - val = getenv (SCM_STRING_CHARS (nam)); - return val ? scm_mem2string (val, strlen (val)) : SCM_BOOL_F; + char *var = scm_to_locale_string (nam); + val = getenv (var); + free (var); + return val ? scm_from_locale_string (val) : SCM_BOOL_F; } #undef FUNC_NAME +/* Get an integer from an environment variable. */ +int +scm_getenv_int (const char *var, int def) +{ + char *end = 0; + char *val = getenv (var); + long res = def; + if (!val) + return def; + res = strtol (val, &end, 10); + if (end == val) + return def; + return res; +} + /* simple exit, without unwinding the scheme stack or flushing ports. */ SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0, (SCM status), - "Terminate the current process without unwinding the Scheme stack.\n" - "This is would typically be useful after a fork. The exit status\n" - "is @var{status} if supplied, otherwise zero.") + "Terminate the current process without unwinding the Scheme\n" + "stack. The exit status is @var{status} if supplied, otherwise\n" + "zero.") #define FUNC_NAME s_scm_primitive_exit { int cstatus = 0; if (!SCM_UNBNDP (status)) - { - SCM_VALIDATE_INUM (1, status); - cstatus = SCM_INUM (status); - } + cstatus = scm_to_int (status); exit (cstatus); } #undef FUNC_NAME +SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0, + (SCM status), + "Terminate the current process using the _exit() system call and\n" + "without unwinding the Scheme stack. The exit status is\n" + "@var{status} if supplied, otherwise zero.\n" + "\n" + "This function is typically useful after a fork, to ensure no\n" + "Scheme cleanups or @code{atexit} handlers are run (those\n" + "usually belonging in the parent rather than the child).") +#define FUNC_NAME s_scm_primitive__exit +{ + int cstatus = 0; + if (!SCM_UNBNDP (status)) + cstatus = scm_to_int (status); + _exit (cstatus); +} +#undef FUNC_NAME + + void scm_init_simpos ()