libguile/simpos.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009,
   2  *   2010, 2012, 2013, 2014 Free Software 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 #include <stdio.h>
  30
  31 #include "libguile/_scm.h"
  32
  33 #include "libguile/scmsigs.h"
  34 #include "libguile/strings.h"
  35
  36 #include "libguile/validate.h"
  37 #include "libguile/simpos.h"
  38 #include "libguile/dynwind.h"
  39
  40 #ifdef HAVE_STRING_H
  41 #include <string.h>
  42 #endif
  43 #include <unistd.h>
  44 #if HAVE_SYS_WAIT_H
  45 # include <sys/wait.h>
  46 #endif
  47
  48 #ifdef __MINGW32__
  49 # include <process.h>   /* for spawnvp and friends */
  50 #endif
  51
  52 #include "posix.h"
  53
  54 \f
  55 extern int system();
  56 \f
  57
  58 #ifdef HAVE_SYSTEM
  59 SCM_DEFINE (scm_system, "system", 0, 1, 0,
  60            (SCM cmd),
  61             "Execute @var{cmd} using the operating system's \"command\n"
  62             "processor\".  Under Unix this is usually the default shell\n"
  63             "@code{sh}.  The value returned is @var{cmd}'s exit status as\n"
  64             "returned by @code{waitpid}, which can be interpreted using\n"
  65             "@code{status:exit-val} and friends.\n"
  66             "\n"
  67             "If @code{system} is called without arguments, return a boolean\n"
  68             "indicating whether the command processor is available.")
  69 #define FUNC_NAME s_scm_system
  70 {
  71   int rv, eno;
  72   char *c_cmd;
  73
  74   if (SCM_UNBNDP (cmd))
  75     {
  76       rv = system (NULL);
  77       return scm_from_bool(rv);
  78     }
  79   SCM_VALIDATE_STRING (1, cmd);
  80   errno = 0;
  81   c_cmd = scm_to_locale_string (cmd);
  82   rv = system (c_cmd);
  83   eno = errno; free (c_cmd); errno = eno;
  84   if (rv == -1 || (rv == 127 && errno != 0))
  85     SCM_SYSERROR;
  86   return scm_from_int (rv);
  87 }
  88 #undef FUNC_NAME
  89 #endif /* HAVE_SYSTEM */
  90
  91
  92 #ifdef HAVE_SYSTEM
  93
  94 SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
  95            (SCM args),
  96 "Execute the command indicated by @var{args}.  The first element must\n"
  97 "be a string indicating the command to be executed, and the remaining\n"
  98 "items must be strings representing each of the arguments to that\n"
  99 "command.\n"
 100 "\n"
 101 "This function returns the exit status of the command as provided by\n"
 102 "@code{waitpid}.  This value can be handled with @code{status:exit-val}\n"
 103 "and the related functions.\n"
 104 "\n"
 105 "@code{system*} is similar to @code{system}, but accepts only one\n"
 106 "string per-argument, and performs no shell interpretation.  The\n"
 107 "command is executed using fork and execlp.  Accordingly this function\n"
 108 "may be safer than @code{system} in situations where shell\n"
 109 "interpretation is not required.\n"
 110 "\n"
 111 "Example: (system* \"echo\" \"foo\" \"bar\")")
 112 #define FUNC_NAME s_scm_system_star
 113 {
 114   if (scm_is_null (args))
 115     SCM_WRONG_NUM_ARGS ();
 116
 117   if (scm_is_pair (args))
 118     {
 119       SCM oldint;
 120       SCM sig_ign;
 121       SCM sigint;
 122       /* SIGQUIT is undefined on MS-Windows.  */
 123 #ifdef SIGQUIT
 124       SCM oldquit;
 125       SCM sigquit;
 126 #endif
 127 #ifdef HAVE_FORK
 128       int pid;
 129 #else
 130       int status;
 131 #endif
 132       char **execargv;
 133
 134       /* allocate before fork */
 135       execargv = scm_i_allocate_string_pointers (args);
 136
 137       /* make sure the child can't kill us (as per normal system call) */
 138       sig_ign = scm_from_ulong ((unsigned long) SIG_IGN);
 139       sigint = scm_from_int (SIGINT);
 140       oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
 141 #ifdef SIGQUIT
 142       sigquit = scm_from_int (SIGQUIT);
 143       oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
 144 #endif
 145
 146 #ifdef HAVE_FORK
 147       pid = fork ();
 148       if (pid == 0)
 149         {
 150           /* child */
 151           execvp (execargv[0], execargv);
 152
 153           /* Something went wrong.  */
 154           fprintf (stderr, "In execvp of %s: %s\n",
 155                    execargv[0], strerror (errno));
 156
 157           /* Exit directly instead of throwing, because otherwise this
 158              process may keep on running.  Use exit status 127, like
 159              shells in this case, as per POSIX
 160              <http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>.  */
 161           _exit (127);
 162         }
 163       else
 164         {
 165           /* parent */
 166           int wait_result, status;
 167
 168           if (pid == -1)
 169             SCM_SYSERROR;
 170
 171           SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
 172           if (wait_result == -1)
 173             SCM_SYSERROR;
 174           scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
 175           scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
 176
 177           return scm_from_int (status);
 178         }
 179 #else  /* !HAVE_FORK */
 180       status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv);
 181       scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
 182 #ifdef SIGQUIT
 183       scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
 184 #endif
 185
 186       return scm_from_int (status);
 187 #endif /* !HAVE_FORK */
 188     }
 189   else
 190     SCM_WRONG_TYPE_ARG (1, args);
 191 }
 192 #undef FUNC_NAME
 193 #endif /* HAVE_SYSTEM */
 194
 195
 196 SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
 197             (SCM nam),
 198             "Looks up the string @var{nam} in the current environment.  The return\n"
 199             "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
 200             "found, in which case the string @code{VALUE} is returned.")
 201 #define FUNC_NAME s_scm_getenv
 202 {
 203   char *val;
 204   char *var = scm_to_locale_string (nam);
 205   val = getenv (var);
 206   free (var);
 207   return val ? scm_from_locale_string (val) : SCM_BOOL_F;
 208 }
 209 #undef FUNC_NAME
 210
 211 /* Get an integer from an environment variable.  */
 212 int
 213 scm_getenv_int (const char *var, int def)
 214 {
 215   char *end = 0;
 216   char *val = getenv (var);
 217   long res = def;
 218   if (!val)
 219     return def;
 220   res = strtol (val, &end, 10);
 221   if (end == val)
 222     return def;
 223   return res;
 224 }
 225
 226 /* simple exit, without unwinding the scheme stack or flushing ports.  */
 227 SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
 228             (SCM status),
 229             "Terminate the current process without unwinding the Scheme\n"
 230             "stack.  The exit status is @var{status} if supplied, otherwise\n"
 231             "zero.")
 232 #define FUNC_NAME s_scm_primitive_exit
 233 {
 234   int cstatus = 0;
 235   if (!SCM_UNBNDP (status))
 236     cstatus = scm_to_int (status);
 237   exit (cstatus);
 238 }
 239 #undef FUNC_NAME
 240
 241 SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0,
 242             (SCM status),
 243             "Terminate the current process using the _exit() system call and\n"
 244             "without unwinding the Scheme stack.  The exit status is\n"
 245             "@var{status} if supplied, otherwise zero.\n"
 246             "\n"
 247             "This function is typically useful after a fork, to ensure no\n"
 248             "Scheme cleanups or @code{atexit} handlers are run (those\n"
 249             "usually belonging in the parent rather than the child).")
 250 #define FUNC_NAME s_scm_primitive__exit
 251 {
 252   int cstatus = 0;
 253   if (!SCM_UNBNDP (status))
 254     cstatus = scm_to_int (status);
 255   _exit (cstatus);
 256 }
 257 #undef FUNC_NAME
 258
 259
 260
 261 void
 262 scm_init_simpos ()
 263 {
 264 #include "libguile/simpos.x"
 265 }
 266
 267
 268 /*
 269   Local Variables:
 270   c-file-style: "gnu"
 271   End:
 272 */