libguile/script.c

   1 /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001 Free Software Foundation, Inc.
   2  * This program is free software; you can redistribute it and/or modify
   3  * it under the terms of the GNU General Public License as published by
   4  * the Free Software Foundation; either version 2, or (at your option)
   5  * any later version.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this software; see the file COPYING.  If not, write to
  14  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  15  * Boston, MA 02111-1307 USA
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.  */
  40
  41 /* "script.c" argv tricks for `#!' scripts.
  42    Authors: Aubrey Jaffer and Jim Blandy */
  43
  44 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  45    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  46
  47 #include <stdio.h>
  48 #include <errno.h>
  49 #include <ctype.h>
  50
  51 #include "libguile/_scm.h"
  52 #include "libguile/gh.h"
  53 #include "libguile/load.h"
  54 #include "libguile/version.h"
  55
  56 #include "libguile/validate.h"
  57 #include "libguile/script.h"
  58
  59 #ifdef HAVE_STRING_H
  60 #include <string.h>
  61 #endif
  62
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>             /* for X_OK define */
  65 #endif
  66
  67 #ifdef HAVE_IO_H
  68 #include <io.h>
  69 #endif
  70
  71 /* Concatentate str2 onto str1 at position n and return concatenated
  72    string if file exists; 0 otherwise. */
  73
  74 static char *
  75 scm_cat_path (char *str1, const char *str2, long n)
  76 {
  77   if (!n)
  78     n = strlen (str2);
  79   if (str1)
  80     {
  81       size_t len = strlen (str1);
  82       str1 = (char *) realloc (str1, (size_t) (len + n + 1));
  83       if (!str1)
  84         return 0L;
  85       strncat (str1 + len, str2, n);
  86       return str1;
  87     }
  88   str1 = (char *) malloc ((size_t) (n + 1));
  89   if (!str1)
  90     return 0L;
  91   str1[0] = 0;
  92   strncat (str1, str2, n);
  93   return str1;
  94 }
  95
  96 #if 0
  97 static char *
  98 scm_try_path (char *path)
  99 {
 100   FILE *f;
 101   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
 102   if (!path)
 103     return 0L;
 104   SCM_SYSCALL (f = fopen (path, "r");
 105     );
 106   if (f)
 107     {
 108       fclose (f);
 109       return path;
 110     }
 111   free (path);
 112   return 0L;
 113 }
 114
 115 static char *
 116 scm_sep_init_try (char *path, const char *sep, const char *initname)
 117 {
 118   if (path)
 119     path = scm_cat_path (path, sep, 0L);
 120   if (path)
 121     path = scm_cat_path (path, initname, 0L);
 122   return scm_try_path (path);
 123 }
 124 #endif
 125
 126 #ifndef LINE_INCREMENTORS
 127 #define LINE_INCREMENTORS  '\n'
 128 #ifdef MSDOS
 129 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 130 #else
 131 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 132 #endif /* def MSDOS */
 133 #endif /* ndef LINE_INCREMENTORS */
 134
 135 #ifndef MAXPATHLEN
 136 #define MAXPATHLEN 80
 137 #endif /* ndef MAXPATHLEN */
 138 #ifndef X_OK
 139 #define X_OK 1
 140 #endif /* ndef X_OK */
 141
 142 char *
 143 scm_find_executable (const char *name)
 144 {
 145   char tbuf[MAXPATHLEN];
 146   int i = 0;
 147   FILE *f;
 148
 149   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 150   if (access (name, X_OK))
 151     return 0L;
 152   f = fopen (name, "r");
 153   if (!f)
 154     return 0L;
 155   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 156     {
 157       while (1)
 158         switch (tbuf[i++] = fgetc (f))
 159           {
 160           case /*WHITE_SPACES */ ' ':
 161           case '\t':
 162           case '\r':
 163           case '\f':
 164           case EOF:
 165             tbuf[--i] = 0;
 166             fclose (f);
 167             return scm_cat_path (0L, tbuf, 0L);
 168           }
 169     }
 170   fclose (f);
 171   return scm_cat_path (0L, name, 0L);
 172 }
 173
 174
 175 /* Read a \nnn-style escape.  We've just read the backslash.  */
 176 static int
 177 script_get_octal (FILE *f)
 178 #define FUNC_NAME "script_get_octal"
 179 {
 180   int i;
 181   int value = 0;
 182
 183   for (i = 0; i < 3; i++)
 184     {
 185       int c = getc (f);
 186       if ('0' <= c && c <= '7')
 187         value = (value * 8) + (c - '0');
 188       else
 189         SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
 190                         SCM_EOL);
 191     }
 192   return value;
 193 }
 194 #undef FUNC_NAME
 195
 196
 197 static int
 198 script_get_backslash (FILE *f)
 199 #define FUNC_NAME "script_get_backslash"
 200 {
 201   int c = getc (f);
 202
 203   switch (c)
 204     {
 205     case 'a': return '\a';
 206     case 'b': return '\b';
 207     case 'f': return '\f';
 208     case 'n': return '\n';
 209     case 'r': return '\r';
 210     case 't': return '\t';
 211     case 'v': return '\v';
 212
 213     case '\\':
 214     case ' ':
 215     case '\t':
 216     case '\n':
 217       return c;
 218
 219     case '0': case '1': case '2': case '3':
 220     case '4': case '5': case '6': case '7':
 221       ungetc (c, f);
 222       return script_get_octal (f);
 223
 224     case EOF:
 225       SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
 226       return 0; /* not reached? */
 227
 228     default:
 229       SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
 230       return 0; /* not reached? */
 231     }
 232 }
 233 #undef FUNC_NAME
 234
 235
 236 static char *
 237 script_read_arg (FILE *f)
 238 #define FUNC_NAME "script_read_arg"
 239 {
 240   size_t size = 7;
 241   char *buf = malloc (size + 1);
 242   size_t len = 0;
 243
 244   if (! buf)
 245     return 0;
 246
 247   for (;;)
 248     {
 249       int c = getc (f);
 250       switch (c)
 251         {
 252         case '\\':
 253           c = script_get_backslash (f);
 254           /* The above produces a new character to add to the argument.
 255              Fall through.  */
 256         default:
 257           if (len >= size)
 258             {
 259               size = (size + 1) * 2;
 260               buf = realloc (buf, size);
 261               if (! buf)
 262                 return 0;
 263             }
 264           buf[len++] = c;
 265           break;
 266
 267         case '\n':
 268           /* This may terminate an arg now, but it will terminate the
 269              entire list next time through.  */
 270           ungetc ('\n', f);
 271         case EOF:
 272           if (len == 0)
 273             {
 274               free (buf);
 275               return 0;
 276             }
 277           /* Otherwise, those characters terminate the argument; fall
 278              through.  */
 279         case ' ':
 280           buf[len] = '\0';
 281           return buf;
 282
 283         case '\t':
 284           free (buf);
 285           SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
 286           return 0; /* not reached? */
 287         }
 288     }
 289 }
 290 #undef FUNC_NAME
 291
 292
 293 static int
 294 script_meta_arg_P (char *arg)
 295 {
 296   if ('\\' != arg[0])
 297     return 0L;
 298 #ifdef MSDOS
 299   return !arg[1];
 300 #else
 301   switch (arg[1])
 302     {
 303     case 0:
 304     case '%':
 305     case WHITE_SPACES:
 306       return !0;
 307     default:
 308       return 0L;
 309     }
 310 #endif
 311 }
 312
 313 char **
 314 scm_get_meta_args (int argc, char **argv)
 315 {
 316   int nargc = argc, argi = 1, nargi = 1;
 317   char *narg, **nargv;
 318   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 319     return 0L;
 320   if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
 321       return 0L;
 322   nargv[0] = argv[0];
 323   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 324     {
 325       FILE *f = fopen (argv[++argi], "r");
 326       if (f)
 327         {
 328           nargc--;              /* to compensate for replacement of '\\' */
 329           while (1)
 330             switch (getc (f))
 331               {
 332               case EOF:
 333                 return 0L;
 334               default:
 335                 continue;
 336               case '\n':
 337                 goto found_args;
 338               }
 339         found_args:
 340           while ((narg = script_read_arg (f)))
 341             if (!(nargv = (char **) realloc (nargv,
 342                                              (1 + ++nargc) * sizeof (char *))))
 343                 return 0L;
 344             else
 345               nargv[nargi++] = narg;
 346           fclose (f);
 347           nargv[nargi++] = argv[argi++];
 348         }
 349     }
 350   while (argi <= argc)
 351     nargv[nargi++] = argv[argi++];
 352   return nargv;
 353 }
 354
 355 int
 356 scm_count_argv (char **argv)
 357 {
 358   int argc = 0;
 359   while (argv[argc])
 360     argc++;
 361   return argc;
 362 }
 363
 364
 365 /* For use in error messages.  */
 366 char *scm_usage_name = 0;
 367
 368 void
 369 scm_shell_usage (int fatal, char *message)
 370 {
 371   if (message)
 372     fprintf (stderr, "%s\n", message);
 373
 374   fprintf (stderr,
 375            "Usage: %s OPTION ...\n"
 376            "Evaluate Scheme code, interactively or from a script.\n"
 377            "\n"
 378            "  -s SCRIPT      load Scheme source code from FILE, and exit\n"
 379            "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
 380            "  --             stop scanning arguments; run interactively\n"
 381            "The above switches stop argument processing, and pass all\n"
 382            "remaining arguments as the value of (command-line).\n"
 383            "\n"
 384            "  -l FILE        load Scheme source code from FILE\n"
 385            "  -e FUNCTION    after reading script, apply FUNCTION to\n"
 386            "                 command line arguments\n"
 387            "  -ds            do -s script at this point\n"
 388            "  --debug        start with debugging evaluator and backtraces\n"
 389            "  -q             inhibit loading of user init file\n"
 390            "  --emacs        enable Emacs protocol (experimental)\n"
 391            "  --use-srfi=LS  load SRFI modules for the SRFIs in LS,\n"
 392            "                 which is a list of numbers like \"2,13,14\"\n"
 393            "  -h, --help     display this help and exit\n"
 394            "  -v, --version  display version information and exit\n"
 395            "  \\              read arguments from following script lines\n",
 396            scm_usage_name);
 397
 398   if (fatal)
 399     exit (fatal);
 400 }
 401
 402
 403 /* Some symbols used by the command-line compiler.  */
 404 SCM_SYMBOL (sym_load, "load");
 405 SCM_SYMBOL (sym_eval_string, "eval-string");
 406 SCM_SYMBOL (sym_command_line, "command-line");
 407 SCM_SYMBOL (sym_begin, "begin");
 408 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 409 SCM_SYMBOL (sym_top_repl, "top-repl");
 410 SCM_SYMBOL (sym_quit, "quit");
 411 SCM_SYMBOL (sym_use_srfis, "use-srfis");
 412
 413
 414 /* Given an array of command-line switches, return a Scheme expression
 415    to carry out the actions specified by the switches.
 416
 417    If you told me this should have been written in Scheme, I'd
 418    probably agree.  I'd say I didn't feel comfortable doing that in
 419    the present system.  You'd say, well, fix the system so you are
 420    comfortable doing that.  I'd agree again.  *shrug*
 421  */
 422
 423 static char guile[] = "guile";
 424
 425 SCM
 426 scm_compile_shell_switches (int argc, char **argv)
 427 {
 428   SCM tail = SCM_EOL;           /* We accumulate the list backwards,
 429                                    and then reverse! it before we
 430                                    return it.  */
 431   SCM do_script = SCM_EOL;      /* The element of the list containing
 432                                    the "load" command, in case we get
 433                                    the "-ds" switch.  */
 434   SCM entry_point = SCM_EOL;    /* for -e switch */
 435   int interactive = 1;          /* Should we go interactive when done? */
 436   int inhibit_user_init = 0;    /* Don't load user init file */
 437   int use_emacs_interface = 0;
 438   int i;
 439   char *argv0 = guile;
 440
 441   if (argc > 0)
 442     {
 443       argv0 = argv[0];
 444       scm_usage_name = strrchr (argv[0], '/');
 445       if (! scm_usage_name)
 446         scm_usage_name = argv[0];
 447       else
 448         scm_usage_name++;
 449     }
 450   if (! scm_usage_name)
 451     scm_usage_name = guile;
 452
 453   for (i = 1; i < argc; i++)
 454     {
 455       if (! strcmp (argv[i], "-s")) /* load script */
 456         {
 457           if (++i >= argc)
 458             scm_shell_usage (1, "missing argument to `-s' switch");
 459
 460           /* If we specified the -ds option, do_script points to the
 461              cdr of an expression like (load #f); we replace the car
 462              (i.e., the #f) with the script name.  */
 463           if (!SCM_NULLP (do_script))
 464             {
 465               SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
 466               do_script = SCM_EOL;
 467             }
 468           else
 469             /* Construct an application of LOAD to the script name.  */
 470             tail = scm_cons (scm_cons2 (sym_load,
 471                                         scm_makfrom0str (argv[i]),
 472                                         SCM_EOL),
 473                                tail);
 474           argv0 = argv[i];
 475           i++;
 476           interactive = 0;
 477           break;
 478         }
 479
 480       else if (! strcmp (argv[i], "-c")) /* evaluate expr */
 481         {
 482           if (++i >= argc)
 483             scm_shell_usage (1, "missing argument to `-c' switch");
 484           tail = scm_cons (scm_cons2 (sym_eval_string,
 485                                       scm_makfrom0str (argv[i]),
 486                                       SCM_EOL),
 487                            tail);
 488           i++;
 489           interactive = 0;
 490           break;
 491         }
 492
 493       else if (! strcmp (argv[i], "--")) /* end args; go interactive */
 494         {
 495           i++;
 496           break;
 497         }
 498
 499       else if (! strcmp (argv[i], "-l")) /* load a file */
 500         {
 501           if (++i < argc)
 502             tail = scm_cons (scm_cons2 (sym_load,
 503                                         scm_makfrom0str (argv[i]),
 504                                         SCM_EOL),
 505                              tail);
 506           else
 507             scm_shell_usage (1, "missing argument to `-l' switch");
 508         }
 509
 510       else if (! strcmp (argv[i], "-e")) /* entry point */
 511         {
 512           if (++i < argc)
 513             entry_point = gh_symbol2scm (argv[i]);
 514           else
 515             scm_shell_usage (1, "missing argument to `-e' switch");
 516         }
 517
 518       else if (! strcmp (argv[i], "-ds")) /* do script here */
 519         {
 520           /* We put a dummy "load" expression, and let the -s put the
 521              filename in.  */
 522           if (!SCM_NULLP (do_script))
 523             scm_shell_usage (1, "the -ds switch may only be specified once");
 524           do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
 525           tail = scm_cons (scm_cons (sym_load, do_script),
 526                            tail);
 527         }
 528
 529       else if (! strcmp (argv[i], "--debug")) /* debug eval + backtraces */
 530         {
 531           SCM_DEVAL_P = 1;
 532           SCM_BACKTRACE_P = 1;
 533           SCM_RECORD_POSITIONS_P = 1;
 534           SCM_RESET_DEBUG_MODE;
 535         }
 536
 537       else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
 538         use_emacs_interface = 1;
 539
 540       else if (! strcmp (argv[i], "-q")) /* don't load user init */
 541         inhibit_user_init = 1;
 542
 543       else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
 544         {
 545           SCM srfis = SCM_EOL;  /* List of requested SRFIs.  */
 546           char * p = argv[i] + 11;
 547           while (*p)
 548             {
 549               long num;
 550               char * end;
 551
 552               num = strtol (p, &end, 10);
 553               if (end - p > 0)
 554                 {
 555                   srfis = scm_cons (scm_long2num (num), srfis);
 556                   if (*end)
 557                     {
 558                       if (*end == ',')
 559                         p = end + 1;
 560                       else
 561                         scm_shell_usage (1, "invalid SRFI specification");
 562                     }
 563                   else
 564                     break;
 565                 }
 566               else
 567                 scm_shell_usage (1, "invalid SRFI specification");
 568             }
 569           if (scm_ilength (srfis) <= 0)
 570             scm_shell_usage (1, "invalid SRFI specification");
 571           srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
 572           tail = scm_cons (scm_list_2 (sym_use_srfis,
 573                                        scm_list_2 (scm_sym_quote, srfis)),
 574                            tail);
 575         }
 576
 577       else if (! strcmp (argv[i], "-h")
 578                || ! strcmp (argv[i], "--help"))
 579         {
 580           scm_shell_usage (0, 0);
 581           exit (0);
 582         }
 583
 584       else if (! strcmp (argv[i], "-v")
 585                || ! strcmp (argv[i], "--version"))
 586         {
 587           /* Print version number.  */
 588           printf ("Guile %s\n"
 589                   "Copyright (c) 1995, 1996, 1997, 2000 Free Software Foundation\n"
 590                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 591                   "certain other uses are permitted as well.  For details, see the file\n"
 592                   "`COPYING', which is included in the Guile distribution.\n"
 593                   "There is no warranty, to the extent permitted by law.\n",
 594                   SCM_STRING_CHARS (scm_version ()));
 595           exit (0);
 596         }
 597
 598       else
 599         {
 600           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 601                    scm_usage_name, argv[i]);
 602           scm_shell_usage (1, 0);
 603         }
 604     }
 605
 606   /* Check to make sure the -ds got a -s. */
 607   if (!SCM_NULLP (do_script))
 608     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 609
 610   /* Make any remaining arguments available to the
 611      script/command/whatever.  */
 612   scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
 613
 614   /* If the --emacs switch was set, now is when we process it.  */
 615   scm_c_define ("use-emacs-interface", SCM_BOOL (use_emacs_interface));
 616
 617   /* Handle the `-e' switch, if it was specified.  */
 618   if (!SCM_NULLP (entry_point))
 619     tail = scm_cons (scm_cons2 (entry_point,
 620                                 scm_cons (sym_command_line, SCM_EOL),
 621                                 SCM_EOL),
 622                        tail);
 623
 624   /* If we didn't end with a -c or a -s, start the repl.  */
 625   if (interactive)
 626     {
 627       tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
 628     }
 629   else
 630     {
 631       /* After doing all the other actions prescribed by the command line,
 632          quit.  */
 633       tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
 634                        tail);
 635       /* Allow asyncs (signal handlers etc.) to be run.  */
 636       scm_mask_ints = 0;
 637     }
 638
 639   /* After the following line, actions will be added to the front. */
 640   tail = scm_reverse_x (tail, SCM_UNDEFINED);
 641
 642   /* If we didn't end with a -c or a -s and didn't supply a -q, load
 643      the user's customization file.  */
 644   if (interactive && !inhibit_user_init)
 645     {
 646       tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
 647     }
 648
 649   {
 650     SCM val = scm_cons (sym_begin, tail);
 651
 652 #if 0
 653     scm_write (val, SCM_UNDEFINED);
 654     scm_newline (SCM_UNDEFINED);
 655 #endif
 656
 657     return val;
 658   }
 659 }
 660
 661
 662 void
 663 scm_shell (int argc, char **argv)
 664 {
 665   /* If present, add SCSH-style meta-arguments from the top of the
 666      script file to the argument vector.  See the SCSH manual: "The
 667      meta argument" for more details.  */
 668   {
 669     char **new_argv = scm_get_meta_args (argc, argv);
 670
 671     if (new_argv)
 672       {
 673         argv = new_argv;
 674         argc = scm_count_argv (new_argv);
 675       }
 676   }
 677
 678   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
 679                                      scm_current_module ())));
 680 }
 681
 682
 683 void
 684 scm_init_script ()
 685 {
 686 #ifndef SCM_MAGIC_SNARFER
 687 #include "libguile/script.x"
 688 #endif
 689 }
 690
 691 /*
 692   Local Variables:
 693   c-file-style: "gnu"
 694   End:
 695 */