libguile/script.c

   1 /* Copyright (C) 1994-1998, 2000-2011, 2013 Free Software Foundation, Inc.
   2  * This library is free software; you can redistribute it and/or
   3  * modify it under the terms of the GNU Lesser General Public License
   4  * as published by the Free Software Foundation; either version 3 of
   5  * the License, or (at your option) any later version.
   6  *
   7  * This library is distributed in the hope that it will be useful, but
   8  * WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  10  * Lesser General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU Lesser General Public
  13  * License along with this library; if not, write to the Free Software
  14  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  15  * 02110-1301 USA
  16  */
  17
  18 /* "script.c" argv tricks for `#!' scripts.
  19    Authors: Aubrey Jaffer and Jim Blandy */
  20
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <localcharset.h>
  26 #include <stdlib.h>
  27 #include <stdio.h>
  28 #include <errno.h>
  29 #include <ctype.h>
  30 #include <uniconv.h>
  31
  32 #include "libguile/_scm.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/feature.h"
  35 #include "libguile/load.h"
  36 #include "libguile/read.h"
  37 #include "libguile/script.h"
  38 #include "libguile/strings.h"
  39 #include "libguile/strports.h"
  40 #include "libguile/validate.h"
  41 #include "libguile/version.h"
  42 #include "libguile/vm.h"
  43
  44 #ifdef HAVE_STRING_H
  45 #include <string.h>
  46 #endif
  47
  48 #ifdef HAVE_UNISTD_H
  49 #include <unistd.h>             /* for X_OK define */
  50 #endif
  51
  52 #ifdef HAVE_IO_H
  53 #include <io.h>
  54 #endif
  55
  56 /* Concatentate str2 onto str1 at position n and return concatenated
  57    string if file exists; 0 otherwise. */
  58
  59 static char *
  60 scm_cat_path (char *str1, const char *str2, long n)
  61 {
  62   if (!n)
  63     n = strlen (str2);
  64   if (str1)
  65     {
  66       size_t len = strlen (str1);
  67       str1 = (char *) realloc (str1, (size_t) (len + n + 1));
  68       if (!str1)
  69         return 0L;
  70       strncat (str1 + len, str2, n);
  71       return str1;
  72     }
  73   str1 = (char *) scm_malloc ((size_t) (n + 1));
  74   if (!str1)
  75     return 0L;
  76   str1[0] = 0;
  77   strncat (str1, str2, n);
  78   return str1;
  79 }
  80
  81 #if 0
  82 static char *
  83 scm_try_path (char *path)
  84 {
  85   FILE *f;
  86   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  87   if (!path)
  88     return 0L;
  89   SCM_SYSCALL (f = fopen (path, "r");
  90     );
  91   if (f)
  92     {
  93       fclose (f);
  94       return path;
  95     }
  96   free (path);
  97   return 0L;
  98 }
  99
 100 static char *
 101 scm_sep_init_try (char *path, const char *sep, const char *initname)
 102 {
 103   if (path)
 104     path = scm_cat_path (path, sep, 0L);
 105   if (path)
 106     path = scm_cat_path (path, initname, 0L);
 107   return scm_try_path (path);
 108 }
 109 #endif
 110
 111 #ifndef LINE_INCREMENTORS
 112 #define LINE_INCREMENTORS  '\n'
 113 #ifdef MSDOS
 114 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 115 #else
 116 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 117 #endif /* def MSDOS */
 118 #endif /* ndef LINE_INCREMENTORS */
 119
 120 #ifndef MAXPATHLEN
 121 #define MAXPATHLEN 80
 122 #endif /* ndef MAXPATHLEN */
 123 #ifndef X_OK
 124 #define X_OK 1
 125 #endif /* ndef X_OK */
 126
 127 char *
 128 scm_find_executable (const char *name)
 129 {
 130   char tbuf[MAXPATHLEN];
 131   int i = 0, c;
 132   FILE *f;
 133
 134   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 135   if (access (name, X_OK))
 136     return 0L;
 137   f = fopen (name, "r");
 138   if (!f)
 139     return 0L;
 140   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 141     {
 142       while (1)
 143         switch (c = fgetc (f))
 144           {
 145           case /*WHITE_SPACES */ ' ':
 146           case '\t':
 147           case '\r':
 148           case '\f':
 149           case EOF:
 150             tbuf[i] = 0;
 151             fclose (f);
 152             return scm_cat_path (0L, tbuf, 0L);
 153           default:
 154             tbuf[i++] = c;
 155             break;
 156           }
 157     }
 158   fclose (f);
 159   return scm_cat_path (0L, name, 0L);
 160 }
 161
 162
 163 /* Read a \nnn-style escape.  We've just read the backslash.  */
 164 static int
 165 script_get_octal (FILE *f)
 166 #define FUNC_NAME "script_get_octal"
 167 {
 168   int i;
 169   int value = 0;
 170
 171   for (i = 0; i < 3; i++)
 172     {
 173       int c = getc (f);
 174       if ('0' <= c && c <= '7')
 175         value = (value * 8) + (c - '0');
 176       else
 177         SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
 178                         SCM_EOL);
 179     }
 180   return value;
 181 }
 182 #undef FUNC_NAME
 183
 184
 185 static int
 186 script_get_backslash (FILE *f)
 187 #define FUNC_NAME "script_get_backslash"
 188 {
 189   int c = getc (f);
 190
 191   switch (c)
 192     {
 193     case 'a': return '\a';
 194     case 'b': return '\b';
 195     case 'f': return '\f';
 196     case 'n': return '\n';
 197     case 'r': return '\r';
 198     case 't': return '\t';
 199     case 'v': return '\v';
 200
 201     case '\\':
 202     case ' ':
 203     case '\t':
 204     case '\n':
 205       return c;
 206
 207     case '0': case '1': case '2': case '3':
 208     case '4': case '5': case '6': case '7':
 209       ungetc (c, f);
 210       return script_get_octal (f);
 211
 212     case EOF:
 213       SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
 214       return 0; /* not reached? */
 215
 216     default:
 217       SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
 218       return 0; /* not reached? */
 219     }
 220 }
 221 #undef FUNC_NAME
 222
 223
 224 static char *
 225 script_read_arg (FILE *f)
 226 #define FUNC_NAME "script_read_arg"
 227 {
 228   size_t size = 7;
 229   char *buf = scm_malloc (size + 1);
 230   size_t len = 0;
 231
 232   if (! buf)
 233     return 0;
 234
 235   for (;;)
 236     {
 237       int c = getc (f);
 238       switch (c)
 239         {
 240         case '\\':
 241           c = script_get_backslash (f);
 242           /* The above produces a new character to add to the argument.
 243              Fall through.  */
 244         default:
 245           if (len >= size)
 246             {
 247               size = (size + 1) * 2;
 248               buf = realloc (buf, size);
 249               if (! buf)
 250                 return 0;
 251             }
 252           buf[len++] = c;
 253           break;
 254
 255         case '\n':
 256           /* This may terminate an arg now, but it will terminate the
 257              entire list next time through.  */
 258           ungetc ('\n', f);
 259         case EOF:
 260           if (len == 0)
 261             {
 262               free (buf);
 263               return 0;
 264             }
 265           /* Otherwise, those characters terminate the argument; fall
 266              through.  */
 267         case ' ':
 268           buf[len] = '\0';
 269           return buf;
 270
 271         case '\t':
 272           free (buf);
 273           SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
 274           return 0; /* not reached? */
 275         }
 276     }
 277 }
 278 #undef FUNC_NAME
 279
 280
 281 static int
 282 script_meta_arg_P (char *arg)
 283 {
 284   if ('\\' != arg[0])
 285     return 0L;
 286 #ifdef MSDOS
 287   return !arg[1];
 288 #else
 289   switch (arg[1])
 290     {
 291     case 0:
 292     case '%':
 293     case WHITE_SPACES:
 294       return !0;
 295     default:
 296       return 0L;
 297     }
 298 #endif
 299 }
 300
 301 char **
 302 scm_get_meta_args (int argc, char **argv)
 303 {
 304   int nargc = argc, argi = 1, nargi = 1;
 305   char *narg, **nargv;
 306   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 307     return 0L;
 308   if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
 309       return 0L;
 310   nargv[0] = argv[0];
 311   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 312     {
 313       FILE *f = fopen (argv[++argi], "r");
 314       if (f)
 315         {
 316           nargc--;              /* to compensate for replacement of '\\' */
 317           while (1)
 318             switch (getc (f))
 319               {
 320               case EOF:
 321                 free (nargv);
 322                 return 0L;
 323               default:
 324                 continue;
 325               case '\n':
 326                 goto found_args;
 327               }
 328         found_args:
 329           /* FIXME: we leak the result of calling script_read_arg.  */
 330           while ((narg = script_read_arg (f)))
 331             if (!(nargv = (char **) realloc (nargv,
 332                                              (1 + ++nargc) * sizeof (char *))))
 333                 return 0L;
 334             else
 335               nargv[nargi++] = narg;
 336           fclose (f);
 337           nargv[nargi++] = argv[argi++];
 338         }
 339     }
 340   while (argi <= argc)
 341     nargv[nargi++] = argv[argi++];
 342   return nargv;
 343 }
 344
 345 int
 346 scm_count_argv (char **argv)
 347 {
 348   int argc = 0;
 349   while (argv[argc])
 350     argc++;
 351   return argc;
 352 }
 353
 354
 355 /* For use in error messages.  */
 356 char *scm_usage_name = 0;
 357
 358 void
 359 scm_shell_usage (int fatal, char *message)
 360 {
 361   scm_call_3 (scm_c_private_ref ("ice-9 command-line",
 362                                  "shell-usage"),
 363               (scm_usage_name
 364                ? scm_from_locale_string (scm_usage_name)
 365                : scm_from_latin1_string ("guile")),
 366               scm_from_bool (fatal),
 367               (message
 368                ? scm_from_locale_string (message)
 369                : SCM_BOOL_F));
 370 }
 371
 372 /* Return a list of strings from ARGV, which contains ARGC strings
 373    assumed to be encoded in the current locale.  Use
 374    `environ_locale_charset' instead of relying on
 375    `scm_from_locale_string' because the user hasn't had a change to call
 376    (setlocale LC_ALL "") yet.
 377
 378    XXX: This hack is for 2.0 and will be removed in the next stable
 379    series where the `setlocale' call will be implicit.  See
 380    <http://lists.gnu.org/archive/html/guile-devel/2011-11/msg00040.html>
 381    for details.  */
 382 static SCM
 383 locale_arguments_to_string_list (int argc, char **const argv)
 384 {
 385   int i;
 386   SCM lst;
 387   const char *encoding;
 388
 389   encoding = environ_locale_charset ();
 390   for (i = argc - 1, lst = SCM_EOL;
 391        i >= 0;
 392        i--)
 393     lst = scm_cons (scm_from_stringn (argv[i], (size_t) -1, encoding,
 394                                       SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE),
 395                     lst);
 396
 397   return lst;
 398 }
 399
 400 /* Set the value returned by `program-arguments', given ARGC and ARGV.  */
 401 void
 402 scm_i_set_boot_program_arguments (int argc, char *argv[])
 403 {
 404   scm_fluid_set_x (scm_program_arguments_fluid,
 405                    locale_arguments_to_string_list (argc, argv));
 406 }
 407
 408 /* Given an array of command-line switches, return a Scheme expression
 409    to carry out the actions specified by the switches.
 410  */
 411
 412 SCM
 413 scm_compile_shell_switches (int argc, char **argv)
 414 {
 415   return scm_call_2 (scm_c_public_ref ("ice-9 command-line",
 416                                        "compile-shell-switches"),
 417                      locale_arguments_to_string_list (argc, argv),
 418                      (scm_usage_name
 419                       ? scm_from_locale_string (scm_usage_name)
 420                       : scm_from_latin1_string ("guile")));
 421 }
 422
 423
 424 void
 425 scm_shell (int argc, char **argv)
 426 {
 427   /* If present, add SCSH-style meta-arguments from the top of the
 428      script file to the argument vector.  See the SCSH manual: "The
 429      meta argument" for more details.  */
 430   {
 431     char **new_argv = scm_get_meta_args (argc, argv);
 432
 433     if (new_argv)
 434       {
 435         argv = new_argv;
 436         argc = scm_count_argv (new_argv);
 437       }
 438   }
 439
 440   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
 441                                      scm_current_module ())));
 442 }
 443
 444
 445 void
 446 scm_init_script ()
 447 {
 448 #include "libguile/script.x"
 449 }
 450
 451 /*
 452   Local Variables:
 453   c-file-style: "gnu"
 454   End:
 455 */