X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/bb73cc183294b1a07306da0d3b6c038d98af0ee8..653ccd78fa6770c692f5a737ad70de5aedbfcc7f:/libguile/simpos.c diff --git a/libguile/simpos.c b/libguile/simpos.c dissimilarity index 93% index 9973e5ff5..84b8b9d67 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,160 +1,231 @@ -/* Copyright (C) 1995,1996 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 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. - * - * 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. */ - - -#include -#include "_scm.h" - -#include "scmsigs.h" -#include "simpos.h" - -#ifdef HAVE_STRING_H -#include -#endif -#ifdef HAVE_UNISTD_H -#include -#endif - - -extern int system(); - - -#ifndef _Windows -SCM_PROC(s_system, "system", 1, 0, 0, scm_system); - -SCM -scm_system(cmd) - SCM cmd; -{ - SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system); - if (SCM_ROSTRINGP (cmd)) - cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0); -# ifdef AZTEC_C - cmd = SCM_MAKINUM(Execute(SCM_ROCHARS(cmd), 0, 0)); -# else - cmd = SCM_MAKINUM(0L+system(SCM_ROCHARS(cmd))); -# endif - return cmd; -} -#endif - -extern char *getenv(); -SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv); - -SCM -scm_getenv(nam) - SCM nam; -{ - char *val; - SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv); - if (SCM_ROSTRINGP (nam)) - nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); - val = getenv(SCM_CHARS(nam)); - return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; -} - -/* I have a feeling this whole arrangement below is a bad idea. One - should always test for the presence or absence of a particular - feature, instead of checking the system name. Older versions of a - system may lack features posessed by new ones, and a feature - appearing on one system will soon appear on others. And autoconf - provides the mechanisms for detecting features. -JimB */ - -#ifdef _AIX -# define SYSTNAME "AIX" -#endif -#ifdef vms -# define SYSTNAME "VMS" -#endif -#if defined (unix) || defined (__unix) || defined(__CYGWIN32__) -# define SYSTNAME "UNIX" -#endif -#ifdef MWC -# define SYSTNAME "COHERENT" -#endif -#ifdef _Windows -# define SYSTNAME "WINDOWS" -#else -# ifdef MSDOS -# define SYSTNAME "MS-DOS" -# endif -#endif -#ifdef __EMX__ -# define SYSTNAME "OS/2" -#endif -#ifdef __IBMC__ -# define SYSTNAME "OS/2" -#endif -#ifdef THINK_C -# define SYSTNAME "THINKC" -#endif -#ifdef AMIGA -# define SYSTNAME "AMIGA" -#endif -#ifdef atarist -# define SYSTNAME "ATARIST" -#endif -#ifdef mach -# define SYSTNAME "MACH" -#endif -#ifdef ARM_ULIB -# define SYSTNAME "ACORN" -#endif - -SCM_PROC(s_software_type, "software-type", 0, 0, 0, scm_software_type); - -SCM -scm_software_type() -{ -#ifdef nosve - return SCM_CAR(scm_intern("nosve", 5)); -#else - return SCM_CAR(scm_intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); -#endif -} - - -void -scm_init_simpos () -{ -#include "simpos.x" -} - +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 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 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 + * 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., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include /* for SIG constants */ +#include /* for getenv */ + +#include "libguile/_scm.h" + +#include "libguile/scmsigs.h" +#include "libguile/strings.h" + +#include "libguile/validate.h" +#include "libguile/simpos.h" +#include "libguile/dynwind.h" + +#ifdef HAVE_STRING_H +#include +#endif +#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 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\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, eno; + char *c_cmd; + + if (SCM_UNBNDP (cmd)) + { + rv = system (NULL); + return scm_from_bool(rv); + } + SCM_VALIDATE_STRING (1, cmd); + errno = 0; + 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; + return scm_from_int (rv); +} +#undef FUNC_NAME +#endif /* HAVE_SYSTEM */ + + +#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" + "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; + 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\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)) + 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 () +{ +#include "libguile/simpos.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/