libguile/simpos.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009,
   2  *   2010, 2012, 2013 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 #ifdef HAVE_UNISTD_H
  44 #include <unistd.h>
  45 #endif
  46 #if HAVE_SYS_WAIT_H
  47 # include <sys/wait.h>
  48 #endif
  49
  50 #include "posix.h"
  51
  52 \f
  53 extern int system();
  54 \f
  55
  56 #ifdef HAVE_SYSTEM
  57 SCM_DEFINE (scm_system, "system", 0, 1, 0,
  58            (SCM cmd),
  59             "Execute @var{cmd} using the operating system's \"command\n"
  60             "processor\".  Under Unix this is usually the default shell\n"
  61             "@code{sh}.  The value returned is @var{cmd}'s exit status as\n"
  62             "returned by @code{waitpid}, which can be interpreted using\n"
  63             "@code{status:exit-val} and friends.\n"
  64             "\n"
  65             "If @code{system} is called without arguments, return a boolean\n"
  66             "indicating whether the command processor is available.")
  67 #define FUNC_NAME s_scm_system
  68 {
  69   int rv, eno;
  70   char *c_cmd;
  71
  72   if (SCM_UNBNDP (cmd))
  73     {
  74       rv = system (NULL);
  75       return scm_from_bool(rv);
  76     }
  77   SCM_VALIDATE_STRING (1, cmd);
  78   errno = 0;
  79   c_cmd = scm_to_locale_string (cmd);
  80   rv = system (c_cmd);
  81   eno = errno; free (c_cmd); errno = eno;
  82   if (rv == -1 || (rv == 127 && errno != 0))
  83     SCM_SYSERROR;
  84   return scm_from_int (rv);
  85 }
  86 #undef FUNC_NAME
  87 #endif /* HAVE_SYSTEM */
  88
  89
  90 #ifdef HAVE_SYSTEM
  91 #ifdef HAVE_WAITPID
  92
  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 oldquit;
 121       SCM sig_ign;
 122       SCM sigint;
 123       SCM sigquit;
 124       int pid;
 125       char **execargv;
 126
 127       /* allocate before fork */
 128       execargv = scm_i_allocate_string_pointers (args);
 129
 130       /* make sure the child can't kill us (as per normal system call) */
 131       sig_ign = scm_from_ulong ((unsigned long) SIG_IGN);
 132       sigint = scm_from_int (SIGINT);
 133       sigquit = scm_from_int (SIGQUIT);
 134       oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
 135       oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
 136
 137       pid = fork ();
 138       if (pid == 0)
 139         {
 140           /* child */
 141           execvp (execargv[0], execargv);
 142
 143           /* Something went wrong.  */
 144           fprintf (stderr, "In execvp of %s: %s\n",
 145                    execargv[0], strerror (errno));
 146
 147           /* Exit directly instead of throwing, because otherwise this
 148              process may keep on running.  Use exit status 127, like
 149              shells in this case, as per POSIX
 150              <http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>.  */
 151           _exit (127);
 152         }
 153       else
 154         {
 155           /* parent */
 156           int wait_result, status;
 157
 158           if (pid == -1)
 159             SCM_SYSERROR;
 160
 161           SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
 162           if (wait_result == -1)
 163             SCM_SYSERROR;
 164           scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
 165           scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
 166
 167           return scm_from_int (status);
 168         }
 169     }
 170   else
 171     SCM_WRONG_TYPE_ARG (1, args);
 172 }
 173 #undef FUNC_NAME
 174 #endif /* HAVE_WAITPID */
 175 #endif /* HAVE_SYSTEM */
 176
 177
 178 SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
 179             (SCM nam),
 180             "Looks up the string @var{nam} in the current environment.  The return\n"
 181             "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
 182             "found, in which case the string @code{VALUE} is returned.")
 183 #define FUNC_NAME s_scm_getenv
 184 {
 185   char *val;
 186   char *var = scm_to_locale_string (nam);
 187   val = getenv (var);
 188   free (var);
 189   return val ? scm_from_locale_string (val) : SCM_BOOL_F;
 190 }
 191 #undef FUNC_NAME
 192
 193 /* Get an integer from an environment variable.  */
 194 int
 195 scm_getenv_int (const char *var, int def)
 196 {
 197   char *end = 0;
 198   char *val = getenv (var);
 199   long res = def;
 200   if (!val)
 201     return def;
 202   res = strtol (val, &end, 10);
 203   if (end == val)
 204     return def;
 205   return res;
 206 }
 207
 208 /* simple exit, without unwinding the scheme stack or flushing ports.  */
 209 SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
 210             (SCM status),
 211             "Terminate the current process without unwinding the Scheme\n"
 212             "stack.  The exit status is @var{status} if supplied, otherwise\n"
 213             "zero.")
 214 #define FUNC_NAME s_scm_primitive_exit
 215 {
 216   int cstatus = 0;
 217   if (!SCM_UNBNDP (status))
 218     cstatus = scm_to_int (status);
 219   exit (cstatus);
 220 }
 221 #undef FUNC_NAME
 222
 223 SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0,
 224             (SCM status),
 225             "Terminate the current process using the _exit() system call and\n"
 226             "without unwinding the Scheme stack.  The exit status is\n"
 227             "@var{status} if supplied, otherwise zero.\n"
 228             "\n"
 229             "This function is typically useful after a fork, to ensure no\n"
 230             "Scheme cleanups or @code{atexit} handlers are run (those\n"
 231             "usually belonging in the parent rather than the child).")
 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
 242
 243 void
 244 scm_init_simpos ()
 245 {
 246 #include "libguile/simpos.x"
 247 }
 248
 249
 250 /*
 251   Local Variables:
 252   c-file-style: "gnu"
 253   End:
 254 */