libguile/simpos.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software
   2  * Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  17  */
  18
  19
  20 \f
  21 #if HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <errno.h>
  26 #include <signal.h>  /* for SIG constants */
  27 #include <stdlib.h>  /* for getenv */
  28
  29 #include "libguile/_scm.h"
  30
  31 #include "libguile/scmsigs.h"
  32 #include "libguile/strings.h"
  33
  34 #include "libguile/validate.h"
  35 #include "libguile/simpos.h"
  36
  37 #ifdef HAVE_STRING_H
  38 #include <string.h>
  39 #endif
  40 #ifdef HAVE_UNISTD_H
  41 #include <unistd.h>
  42 #endif
  43 #if HAVE_SYS_WAIT_H
  44 # include <sys/wait.h>
  45 #endif
  46
  47 #include "posix.h"
  48
  49 \f
  50 extern int system();
  51 \f
  52
  53 #ifdef HAVE_SYSTEM
  54 SCM_DEFINE (scm_system, "system", 0, 1, 0,
  55            (SCM cmd),
  56             "Execute @var{cmd} using the operating system's \"command\n"
  57             "processor\".  Under Unix this is usually the default shell\n"
  58             "@code{sh}.  The value returned is @var{cmd}'s exit status as\n"
  59             "returned by @code{waitpid}, which can be interpreted using\n"
  60             "@code{status:exit-val} and friends.\n"
  61             "\n"
  62             "If @code{system} is called without arguments, return a boolean\n"
  63             "indicating whether the command processor is available.")
  64 #define FUNC_NAME s_scm_system
  65 {
  66   int rv;
  67
  68   if (SCM_UNBNDP (cmd))
  69     {
  70       rv = system (NULL);
  71       return scm_from_bool(rv);
  72     }
  73   SCM_VALIDATE_STRING (1, cmd);
  74   errno = 0;
  75   rv = system (SCM_STRING_CHARS (cmd));
  76   if (rv == -1 || (rv == 127 && errno != 0))
  77     SCM_SYSERROR;
  78   return SCM_MAKINUM (rv);
  79 }
  80 #undef FUNC_NAME
  81 #endif /* HAVE_SYSTEM */
  82
  83
  84 #ifdef HAVE_SYSTEM
  85 #ifdef HAVE_WAITPID
  86
  87 /* return a newly allocated array of char pointers to each of the strings
  88    in args, with a terminating NULL pointer.  */
  89 /* Note: a similar function is defined in dynl.c, but we don't necessarily
  90    want to export it.  */
  91 static char **
  92 allocate_string_pointers (SCM args)
  93 {
  94   char **result;
  95   int n_args = scm_ilength (args);
  96   int i;
  97
  98   SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
  99   result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
 100   result[n_args] = NULL;
 101   for (i = 0; i < n_args; i++)
 102     {
 103       SCM car = SCM_CAR (args);
 104
 105       if (!SCM_STRINGP (car))
 106         {
 107           free (result);
 108           scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
 109         }
 110       result[i] = SCM_STRING_CHARS (SCM_CAR (args));
 111       args = SCM_CDR (args);
 112     }
 113   return result;
 114 }
 115
 116 SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 117            (SCM args),
 118 "Execute the command indicated by @var{args}.  The first element must\n"
 119 "be a string indicating the command to be executed, and the remaining\n"
 120 "items must be strings representing each of the arguments to that\n"
 121 "command.\n"
 122 "\n"
 123 "This function returns the exit status of the command as provided by\n"
 124 "@code{waitpid}.  This value can be handled with @code{status:exit-val}\n"
 125 "and the related functions.\n"
 126 "\n"
 127 "@code{system*} is similar to @code{system}, but accepts only one\n"
 128 "string per-argument, and performs no shell interpretation.  The\n"
 129 "command is executed using fork and execlp.  Accordingly this function\n"
 130 "may be safer than @code{system} in situations where shell\n"
 131 "interpretation is not required.\n"
 132 "\n"
 133 "Example: (system* \"echo\" \"foo\" \"bar\")")
 134 #define FUNC_NAME s_scm_system_star
 135 {
 136   if (SCM_NULLP (args))
 137     SCM_WRONG_NUM_ARGS ();
 138
 139   if (SCM_CONSP (args))
 140     {
 141       SCM oldint;
 142       SCM oldquit;
 143       SCM sig_ign;
 144       SCM sigint;
 145       SCM sigquit;
 146       int pid;
 147       char **execargv;
 148
 149       SCM_VALIDATE_STRING (1, SCM_CAR (args));
 150       /* allocate before fork */
 151       execargv = allocate_string_pointers (args);
 152
 153       /* make sure the child can't kill us (as per normal system call) */
 154       sig_ign = scm_long2num ((long) SIG_IGN);
 155       sigint = scm_long2num (SIGINT);
 156       sigquit = scm_long2num (SIGQUIT);
 157       oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
 158       oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
 159
 160       pid = fork ();
 161       if (pid == 0)
 162         {
 163           /* child */
 164           execvp (SCM_STRING_CHARS (SCM_CAR (args)), execargv);
 165           scm_remember_upto_here_1 (args);
 166           SCM_SYSERROR;
 167           /* not reached.  */
 168           return SCM_BOOL_F;
 169         }
 170       else
 171         {
 172           /* parent */
 173           int wait_result, status, save_errno;
 174
 175           save_errno = errno;
 176           free (execargv);
 177           errno = save_errno;
 178           if (pid == -1)
 179             SCM_SYSERROR;
 180
 181           SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
 182           if (wait_result == -1) SCM_SYSERROR;
 183           scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
 184           scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
 185           scm_remember_upto_here_2 (oldint, oldquit);
 186           return SCM_MAKINUM (0L + status);
 187         }
 188     }
 189   else
 190     SCM_WRONG_TYPE_ARG (1, SCM_CAR (args));
 191 }
 192 #undef FUNC_NAME
 193 #endif /* HAVE_WAITPID */
 194 #endif /* HAVE_SYSTEM */
 195
 196
 197 SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
 198             (SCM nam),
 199             "Looks up the string @var{name} in the current environment.  The return\n"
 200             "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
 201             "found, in which case the string @code{VALUE} is returned.")
 202 #define FUNC_NAME s_scm_getenv
 203 {
 204   char *val;
 205   SCM_VALIDATE_STRING (1, nam);
 206   val = getenv (SCM_STRING_CHARS (nam));
 207   return val ? scm_mem2string (val, strlen (val)) : SCM_BOOL_F;
 208 }
 209 #undef FUNC_NAME
 210
 211 /* simple exit, without unwinding the scheme stack or flushing ports.  */
 212 SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
 213             (SCM status),
 214             "Terminate the current process without unwinding the Scheme stack.\n"
 215             "This is would typically be useful after a fork.  The exit status\n"
 216             "is @var{status} if supplied, otherwise zero.")
 217 #define FUNC_NAME s_scm_primitive_exit
 218 {
 219   int cstatus = 0;
 220   if (!SCM_UNBNDP (status))
 221     {
 222       SCM_VALIDATE_INUM (1, status);
 223       cstatus = SCM_INUM (status);
 224     }
 225   exit (cstatus);
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 void
 231 scm_init_simpos ()
 232 {
 233 #include "libguile/simpos.x"
 234 }
 235
 236
 237 /*
 238   Local Variables:
 239   c-file-style: "gnu"
 240   End:
 241 */