X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/36284627919a6968174b5f17369349187a2b4b1b..653ccd78fa6770c692f5a737ad70de5aedbfcc7f:/libguile/simpos.c diff --git a/libguile/simpos.c b/libguile/simpos.c index 882088b40..84b8b9d67 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,50 +1,31 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 Free Software + * Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * 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 3 of + * the License, or (at your option) any later version. * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * 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. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#ifdef HAVE_CONFIG_H +# include +#endif #include +#include /* for SIG constants */ +#include /* for getenv */ #include "libguile/_scm.h" @@ -53,6 +34,7 @@ #include "libguile/validate.h" #include "libguile/simpos.h" +#include "libguile/dynwind.h" #ifdef HAVE_STRING_H #include @@ -60,45 +42,131 @@ #ifdef HAVE_UNISTD_H #include #endif +#if HAVE_SYS_WAIT_H +# include +#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" "@code{sh}. The value returned is @var{cmd}'s exit status as\n" - "returned by @code{waitpid}, which can be interpreted using the\n" - "functions above.\n" + "returned by @code{waitpid}, which can be interpreted using\n" + "@code{status:exit-val} and friends.\n" "\n" "If @code{system} is called without arguments, return a boolean\n" "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; - SCM_STRING_COERCE_0TERMINATION_X (cmd); - 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 */ -extern char *getenv(); + +#ifdef HAVE_SYSTEM +#ifdef HAVE_WAITPID + + +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 oldquit; + SCM sig_ign; + SCM sigint; + SCM sigquit; + int pid; + 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); + sigquit = scm_from_int (SIGQUIT); + oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); + oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); + + pid = fork (); + if (pid == 0) + { + /* child */ + execvp (execargv[0], execargv); + SCM_SYSERROR; + /* not reached. */ + return SCM_BOOL_F; + } + 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 + SCM_WRONG_TYPE_ARG (1, args); +} +#undef FUNC_NAME +#endif /* HAVE_WAITPID */ +#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" @@ -107,38 +175,52 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, #define FUNC_NAME s_scm_getenv { char *val; - SCM_VALIDATE_STRING (1, nam); - SCM_STRING_COERCE_0TERMINATION_X (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 /* 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 () { -#ifndef SCM_MAGIC_SNARFER #include "libguile/simpos.x" -#endif }