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 License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * 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., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <errno.h>
  27 #include <signal.h>  /* for SIG constants */
  28 #include <stdlib.h>  /* for getenv */
  29
  30 #include "libguile/_scm.h"
  31
  32 #include "libguile/scmsigs.h"
  33 #include "libguile/strings.h"
  34
  35 #include "libguile/validate.h"
  36 #include "libguile/simpos.h"
  37 #include "libguile/dynwind.h"
  38
  39 #ifdef HAVE_STRING_H
  40 #include <string.h>
  41 #endif
  42 #ifdef HAVE_UNISTD_H
  43 #include <unistd.h>
  44 #endif
  45 #if HAVE_SYS_WAIT_H
  46 # include <sys/wait.h>
  47 #endif
  48
  49 #include "posix.h"
  50
  51 \f
  52 extern int system();
  53 \f
  54
  55 #ifdef HAVE_SYSTEM
  56 SCM_DEFINE (scm_system, "system", 0, 1, 0,
  57            (SCM cmd),
  58             "Execute @var{cmd} using the operating system's \"command\n"
  59             "processor\".  Under Unix this is usually the default shell\n"
  60             "@code{sh}.  The value returned is @var{cmd}'s exit status as\n"
  61             "returned by @code{waitpid}, which can be interpreted using\n"
  62             "@code{status:exit-val} and friends.\n"
  63             "\n"
  64             "If @code{system} is called without arguments, return a boolean\n"
  65             "indicating whether the command processor is available.")
  66 #define FUNC_NAME s_scm_system
  67 {
  68   int rv, eno;
  69   char *c_cmd;
  70
  71   if (SCM_UNBNDP (cmd))
  72     {
  73       rv = system (NULL);
  74       return scm_from_bool(rv);
  75     }
  76   SCM_VALIDATE_STRING (1, cmd);
  77   errno = 0;
  78   c_cmd = scm_to_locale_string (cmd);
  79   rv = system (c_cmd);
  80   eno = errno; free (c_cmd); errno = eno;
  81   if (rv == -1 || (rv == 127 && errno != 0))
  82     SCM_SYSERROR;
  83   return scm_from_int (rv);
  84 }
  85 #undef FUNC_NAME
  86 #endif /* HAVE_SYSTEM */
  87
  88
  89 #ifdef HAVE_SYSTEM
  90 #ifdef HAVE_WAITPID
  91
  92 static void
  93 free_string_pointers (void *data)
  94 {
  95   scm_i_free_string_pointers ((char **)data);
  96 }
  97
  98 SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
  99            (SCM args),
 100 "Execute the command indicated by @var{args}.  The first element must\n"
 101 "be a string indicating the command to be executed, and the remaining\n"
 102 "items must be strings representing each of the arguments to that\n"
 103 "command.\n"
 104 "\n"
 105 "This function returns the exit status of the command as provided by\n"
 106 "@code{waitpid}.  This value can be handled with @code{status:exit-val}\n"
 107 "and the related functions.\n"
 108 "\n"
 109 "@code{system*} is similar to @code{system}, but accepts only one\n"
 110 "string per-argument, and performs no shell interpretation.  The\n"
 111 "command is executed using fork and execlp.  Accordingly this function\n"
 112 "may be safer than @code{system} in situations where shell\n"
 113 "interpretation is not required.\n"
 114 "\n"
 115 "Example: (system* \"echo\" \"foo\" \"bar\")")
 116 #define FUNC_NAME s_scm_system_star
 117 {
 118   if (scm_is_null (args))
 119     SCM_WRONG_NUM_ARGS ();
 120
 121   if (scm_is_pair (args))
 122     {
 123       SCM oldint;
 124       SCM oldquit;
 125       SCM sig_ign;
 126       SCM sigint;
 127       SCM sigquit;
 128       int pid;
 129       char **execargv;
 130
 131       scm_dynwind_begin (0);
 132
 133       /* allocate before fork */
 134       execargv = scm_i_allocate_string_pointers (args);
 135       scm_dynwind_unwind_handler (free_string_pointers, execargv,
 136                                   SCM_F_WIND_EXPLICITLY);
 137
 138       /* make sure the child can't kill us (as per normal system call) */
 139       sig_ign = scm_from_long ((unsigned long) SIG_IGN);
 140       sigint = scm_from_int (SIGINT);
 141       sigquit = scm_from_int (SIGQUIT);
 142       oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
 143       oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
 144
 145       pid = fork ();
 146       if (pid == 0)
 147         {
 148           /* child */
 149           execvp (execargv[0], execargv);
 150           SCM_SYSERROR;
 151           /* not reached.  */
 152           scm_dynwind_end ();
 153           return SCM_BOOL_F;
 154         }
 155       else
 156         {
 157           /* parent */
 158           int wait_result, status;
 159
 160           if (pid == -1)
 161             SCM_SYSERROR;
 162
 163           SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
 164           if (wait_result == -1)
 165             SCM_SYSERROR;
 166           scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
 167           scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
 168
 169           scm_dynwind_end ();
 170           return scm_from_int (status);
 171         }
 172     }
 173   else
 174     SCM_WRONG_TYPE_ARG (1, args);
 175 }
 176 #undef FUNC_NAME
 177 #endif /* HAVE_WAITPID */
 178 #endif /* HAVE_SYSTEM */
 179
 180
 181 SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
 182             (SCM nam),
 183             "Looks up the string @var{name} in the current environment.  The return\n"
 184             "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
 185             "found, in which case the string @code{VALUE} is returned.")
 186 #define FUNC_NAME s_scm_getenv
 187 {
 188   char *val;
 189   char *var = scm_to_locale_string (nam);
 190   val = getenv (var);
 191   free (var);
 192   return val ? scm_from_locale_string (val) : SCM_BOOL_F;
 193 }
 194 #undef FUNC_NAME
 195
 196 /* simple exit, without unwinding the scheme stack or flushing ports.  */
 197 SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
 198             (SCM status),
 199             "Terminate the current process without unwinding the Scheme\n"
 200             "stack.  The exit status is @var{status} if supplied, otherwise\n"
 201             "zero.")
 202 #define FUNC_NAME s_scm_primitive_exit
 203 {
 204   int cstatus = 0;
 205   if (!SCM_UNBNDP (status))
 206     cstatus = scm_to_int (status);
 207   exit (cstatus);
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0,
 212             (SCM status),
 213             "Terminate the current process using the _exit() system call and\n"
 214             "without unwinding the Scheme stack.  The exit status is\n"
 215             "@var{status} if supplied, otherwise zero.\n"
 216             "\n"
 217             "This function is typically useful after a fork, to ensure no\n"
 218             "Scheme cleanups or @code{atexit} handlers are run (those\n"
 219             "usually belonging in the parent rather than the child).")
 220 #define FUNC_NAME s_scm_primitive__exit
 221 {
 222   int cstatus = 0;
 223   if (!SCM_UNBNDP (status))
 224     cstatus = scm_to_int (status);
 225   _exit (cstatus);
 226 }
 227 #undef FUNC_NAME
 228
 229
 230
 231 void
 232 scm_init_simpos ()
 233 {
 234 #include "libguile/simpos.x"
 235 }
 236
 237
 238 /*
 239   Local Variables:
 240   c-file-style: "gnu"
 241   End:
 242 */