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