libguile/script.c

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