libguile/script.c

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