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