libguile/script.c

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