libguile/script.c

   1 /* Copyright (C) 1994, 1995, 1996, 1997, 1998 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 #include <stdio.h>
  45 #include <ctype.h>
  46 #include "_scm.h"
  47 #include "gh.h"
  48 #include "load.h"
  49 #include "version.h"
  50
  51 #include "script.h"
  52
  53 #ifdef HAVE_UNISTD_H
  54 #include <unistd.h>             /* for X_OK define */
  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 (str1, str2, n)
  62      char *str1;
  63      const char *str2;
  64      long n;
  65 {
  66   if (!n)
  67     n = strlen (str2);
  68   if (str1)
  69     {
  70       long len = strlen (str1);
  71       str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1));
  72       if (!str1)
  73         return 0L;
  74       strncat (str1 + len, str2, n);
  75       return str1;
  76     }
  77   str1 = (char *) malloc ((scm_sizet) (n + 1));
  78   if (!str1)
  79     return 0L;
  80   str1[0] = 0;
  81   strncat (str1, str2, n);
  82   return str1;
  83 }
  84
  85 #if 0
  86 static char *
  87 scm_try_path (path)
  88      char *path;
  89 {
  90   FILE *f;
  91   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  92   if (!path)
  93     return 0L;
  94   SCM_SYSCALL (f = fopen (path, "r");
  95     );
  96   if (f)
  97     {
  98       fclose (f);
  99       return path;
 100     }
 101   free (path);
 102   return 0L;
 103 }
 104
 105 static char *
 106 scm_sep_init_try (path, sep, initname)
 107      char *path;
 108      const char *sep, *initname;
 109 {
 110   if (path)
 111     path = scm_cat_path (path, sep, 0L);
 112   if (path)
 113     path = scm_cat_path (path, initname, 0L);
 114   return scm_try_path (path);
 115 }
 116 #endif
 117
 118 #ifndef LINE_INCREMENTORS
 119 #define LINE_INCREMENTORS  '\n'
 120 #ifdef MSDOS
 121 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 122 #else
 123 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 124 #endif /* def MSDOS */
 125 #endif /* ndef LINE_INCREMENTORS */
 126
 127 #ifndef MAXPATHLEN
 128 #define MAXPATHLEN 80
 129 #endif /* ndef MAXPATHLEN */
 130 #ifndef X_OK
 131 #define X_OK 1
 132 #endif /* ndef X_OK */
 133
 134 char *
 135 scm_find_executable (const char *name)
 136 {
 137   char tbuf[MAXPATHLEN];
 138   int i = 0;
 139   FILE *f;
 140
 141   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 142   if (access (name, X_OK))
 143     return 0L;
 144   f = fopen (name, "r");
 145   if (!f)
 146     return 0L;
 147   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 148     {
 149       while (1)
 150         switch (tbuf[i++] = fgetc (f))
 151           {
 152           case /*WHITE_SPACES */ ' ':
 153           case '\t':
 154           case '\r':
 155           case '\f':
 156           case EOF:
 157             tbuf[--i] = 0;
 158             fclose (f);
 159             return scm_cat_path (0L, tbuf, 0L);
 160           }
 161     }
 162   fclose (f);
 163   return scm_cat_path (0L, name, 0L);
 164 }
 165
 166
 167 /* Read a \nnn-style escape.  We've just read the backslash.  */
 168 static int
 169 script_get_octal (f)
 170      FILE *f;
 171 {
 172   int i;
 173   int value = 0;
 174
 175   for (i = 0; i < 3; i++)
 176     {
 177       int c = getc (f);
 178       if ('0' <= c && c <= '7')
 179         value = (value * 8) + (c - '0');
 180       else
 181         scm_wta (SCM_UNDEFINED,
 182                  "malformed script: bad octal backslash escape",
 183                  "script argument parser");
 184     }
 185   return value;
 186 }
 187
 188
 189 static int
 190 script_get_backslash (f)
 191      FILE *f;
 192 {
 193   int c = getc (f);
 194
 195   switch (c)
 196     {
 197     case 'a': return '\a';
 198     case 'b': return '\b';
 199     case 'f': return '\f';
 200     case 'n': return '\n';
 201     case 'r': return '\r';
 202     case 't': return '\t';
 203     case 'v': return '\v';
 204
 205     case '\\':
 206     case ' ':
 207     case '\t':
 208     case '\n':
 209       return c;
 210
 211     case '0': case '1': case '2': case '3':
 212     case '4': case '5': case '6': case '7':
 213       ungetc (c, f);
 214       return script_get_octal (f);
 215
 216     case EOF:
 217       scm_wta (SCM_UNDEFINED,
 218                "malformed script: backslash followed by EOF",
 219                "script argument parser");
 220       return 0; /* not reached? */
 221
 222     default:
 223       scm_wta (SCM_UNDEFINED,
 224                "malformed script: bad backslash sequence",
 225                "script argument parser");
 226       return 0; /* not reached? */
 227     }
 228 }
 229
 230
 231 static char *
 232 script_read_arg (f)
 233      FILE *f;
 234 {
 235   int size = 7;
 236   char *buf = malloc (size + 1);
 237   int len = 0;
 238
 239   if (! buf)
 240     return 0;
 241
 242   for (;;)
 243     {
 244       int c = getc (f);
 245       switch (c)
 246         {
 247         case '\\':
 248           c = script_get_backslash (f);
 249           /* The above produces a new character to add to the argument.
 250              Fall through.  */
 251         default:
 252           if (len >= size)
 253             {
 254               size = (size + 1) * 2;
 255               buf = realloc (buf, size);
 256               if (! buf)
 257                 return 0;
 258             }
 259           buf[len++] = c;
 260           break;
 261
 262         case '\n':
 263           /* This may terminate an arg now, but it will terminate the
 264              entire list next time through.  */
 265           ungetc ('\n', f);
 266         case EOF:
 267           if (len == 0)
 268             {
 269               free (buf);
 270               return 0;
 271             }
 272           /* Otherwise, those characters terminate the argument; fall
 273              through.  */
 274         case ' ':
 275           buf[len] = '\0';
 276           return buf;
 277
 278         case '\t':
 279           free (buf);
 280           scm_wta (SCM_UNDEFINED,
 281                    "malformed script: TAB in meta-arguments",
 282                    "argument parser");
 283           return 0; /* not reached? */
 284         }
 285     }
 286 }
 287
 288
 289 static int
 290 script_meta_arg_P (arg)
 291      char *arg;
 292 {
 293   if ('\\' != arg[0])
 294     return 0L;
 295 #ifdef MSDOS
 296   return !arg[1];
 297 #else
 298   switch (arg[1])
 299     {
 300     case 0:
 301     case '%':
 302     case WHITE_SPACES:
 303       return !0;
 304     default:
 305       return 0L;
 306     }
 307 #endif
 308 }
 309
 310 char **
 311 scm_get_meta_args (argc, argv)
 312      int argc;
 313      char **argv;
 314 {
 315   int nargc = argc, argi = 1, nargi = 1;
 316   char *narg, **nargv;
 317   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 318     return 0L;
 319   if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
 320       return 0L;
 321   nargv[0] = argv[0];
 322   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 323     {
 324       FILE *f = fopen (argv[++argi], "r");
 325       if (f)
 326         {
 327           nargc--;              /* to compensate for replacement of '\\' */
 328           while (1)
 329             switch (getc (f))
 330               {
 331               case EOF:
 332                 return 0L;
 333               default:
 334                 continue;
 335               case '\n':
 336                 goto found_args;
 337               }
 338         found_args:
 339           while ((narg = script_read_arg (f)))
 340             if (!(nargv = (char **) realloc (nargv,
 341                                              (1 + ++nargc) * sizeof (char *))))
 342                 return 0L;
 343             else
 344               nargv[nargi++] = narg;
 345           fclose (f);
 346           nargv[nargi++] = argv[argi++];
 347         }
 348     }
 349   while (argi <= argc)
 350     nargv[nargi++] = argv[argi++];
 351   return nargv;
 352 }
 353
 354 int
 355 scm_count_argv (argv)
 356      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            "  -q             inhibit loading of user init file\n"
 389            "  --emacs        enable Emacs protocol (experimental)\n"
 390            "  -h, --help     display this help and exit\n"
 391            "  -v, --version  display version information and exit\n"
 392            "  \\              read arguments from following script lines\n",
 393            scm_usage_name);
 394
 395   if (fatal)
 396     exit (fatal);
 397 }
 398
 399
 400 /* Some symbols used by the command-line compiler.  */
 401 SCM_SYMBOL (sym_load, "load");
 402 SCM_SYMBOL (sym_eval_string, "eval-string");
 403 SCM_SYMBOL (sym_command_line, "command-line");
 404 SCM_SYMBOL (sym_begin, "begin");
 405 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 406 SCM_SYMBOL (sym_top_repl, "top-repl");
 407 SCM_SYMBOL (sym_quit, "quit");
 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    We load the ice-9 system from here.  It might be nicer if the
 419    libraries initialized from the inner_main function in guile.c (which
 420    will be auto-generated eventually) could assume ice-9 were already
 421    loaded.  Then again, it might be nice if ice-9 could assume that
 422    certain libraries were already loaded.  The solution is to break up
 423    ice-9 into modules which can be frozen and statically linked like any
 424    other module.  Then all the modules can describe their dependencies in
 425    the usual way, and the auto-generated inner_main will do the right
 426    thing. */
 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 i;
 444   char *argv0 = guile;
 445
 446   if (argc > 0)
 447     {
 448       argv0 = argv[0];
 449       scm_usage_name = strrchr (argv[0], '/');
 450       if (! scm_usage_name)
 451         scm_usage_name = argv[0];
 452       else
 453         scm_usage_name++;
 454     }
 455   if (! scm_usage_name)
 456     scm_usage_name = guile;
 457
 458   for (i = 1; i < argc; i++)
 459     {
 460       if (! strcmp (argv[i], "-s")) /* load script */
 461         {
 462           if (++i >= argc)
 463             scm_shell_usage (1, "missing argument to `-s' switch");
 464
 465           /* If we specified the -ds option, do_script points to the
 466              cdr of an expression like (load #f); we replace the car
 467              (i.e., the #f) with the script name.  */
 468           if (do_script != SCM_EOL)
 469             {
 470               SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
 471               do_script = SCM_EOL;
 472             }
 473           else
 474             /* Construct an application of LOAD to the script name.  */
 475             tail = scm_cons (scm_cons2 (sym_load,
 476                                         scm_makfrom0str (argv[i]),
 477                                         SCM_EOL),
 478                                tail);
 479           argv0 = argv[i];
 480           i++;
 481           interactive = 0;
 482           break;
 483         }
 484
 485       else if (! strcmp (argv[i], "-c")) /* evaluate expr */
 486         {
 487           if (++i >= argc)
 488             scm_shell_usage (1, "missing argument to `-c' switch");
 489           tail = scm_cons (scm_cons2 (sym_eval_string,
 490                                       scm_makfrom0str (argv[i]),
 491                                       SCM_EOL),
 492                            tail);
 493           i++;
 494           interactive = 0;
 495           break;
 496         }
 497
 498       else if (! strcmp (argv[i], "--")) /* end args; go interactive */
 499         {
 500           i++;
 501           break;
 502         }
 503
 504       else if (! strcmp (argv[i], "-l")) /* load a file */
 505         {
 506           if (++i < argc)
 507             tail = scm_cons (scm_cons2 (sym_load,
 508                                         scm_makfrom0str (argv[i]),
 509                                         SCM_EOL),
 510                              tail);
 511           else
 512             scm_shell_usage (1, "missing argument to `-l' switch");
 513         }
 514
 515       else if (! strcmp (argv[i], "-e")) /* entry point */
 516         {
 517           if (++i < argc)
 518             entry_point = gh_symbol2scm (argv[i]);
 519           else
 520             scm_shell_usage (1, "missing argument to `-e' switch");
 521         }
 522
 523       else if (! strcmp (argv[i], "-ds")) /* do script here */
 524         {
 525           /* We put a dummy "load" expression, and let the -s put the
 526              filename in.  */
 527           if (do_script != SCM_EOL)
 528             scm_shell_usage (1, "the -ds switch may only be specified once");
 529           do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
 530           tail = scm_cons (scm_cons (sym_load, do_script),
 531                            tail);
 532         }
 533
 534       else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
 535         use_emacs_interface = 1;
 536
 537       else if (! strcmp (argv[i], "-q")) /* don't load user init */
 538         inhibit_user_init = 1;
 539
 540       else if (! strcmp (argv[i], "-h")
 541                || ! strcmp (argv[i], "--help"))
 542         {
 543           scm_shell_usage (0, 0);
 544           exit (0);
 545         }
 546
 547       else if (! strcmp (argv[i], "-v")
 548                || ! strcmp (argv[i], "--version"))
 549         {
 550           /* Print version number.  */
 551           printf ("Guile %s\n"
 552                   "Copyright (c) 1995, 1996, 1997 Free Software Foundation\n"
 553                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 554                   "certain other uses are permitted as well.  For details, see the file\n"
 555                   "`COPYING', which is included in the Guile distribution.\n"
 556                   "There is no warranty, to the extent permitted by law.\n",
 557                   SCM_CHARS (scm_version ()));
 558           exit (0);
 559         }
 560
 561       else
 562         {
 563           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 564                    scm_usage_name, argv[i]);
 565           scm_shell_usage (1, 0);
 566         }
 567     }
 568
 569   /* Check to make sure the -ds got a -s. */
 570   if (do_script != SCM_EOL)
 571     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 572
 573   /* Make any remaining arguments available to the
 574      script/command/whatever.  */
 575   scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
 576
 577   /* If the --emacs switch was set, now is when we process it.  */
 578   {
 579     SCM vcell = scm_sysintern0_no_module_lookup ("use-emacs-interface");
 580     SCM_SETCDR (vcell, SCM_BOOL(use_emacs_interface));
 581   }
 582
 583   /* Handle the `-e' switch, if it was specified.  */
 584   if (entry_point != SCM_EOL)
 585     tail = scm_cons (scm_cons2 (entry_point,
 586                                 scm_cons (sym_command_line, SCM_EOL),
 587                                 SCM_EOL),
 588                        tail);
 589
 590   /* If we didn't end with a -c or a -s, start the repl.  */
 591   if (interactive)
 592     {
 593       tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
 594     }
 595   else
 596     {
 597       /* After doing all the other actions prescribed by the command line,
 598          quit.  */
 599       tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
 600                        tail);
 601       /* Allow asyncs (signal handlers etc.) to be run.  */
 602       scm_mask_ints = 0;
 603     }
 604
 605   /* After the following line, actions will be added to the front. */
 606   tail = scm_reverse_x (tail, SCM_UNDEFINED);
 607
 608   /* If we didn't end with a -c or a -s and didn't supply a -q, load
 609      the user's customization file.  */
 610   if (interactive && !inhibit_user_init)
 611     {
 612       tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
 613     }
 614
 615   {
 616     SCM val = scm_cons (sym_begin, tail);
 617
 618 #if 0
 619     scm_write (val, SCM_UNDEFINED);
 620     scm_newline (SCM_UNDEFINED);
 621 #endif
 622
 623     return val;
 624   }
 625 }
 626
 627
 628 void
 629 scm_shell (argc, argv)
 630      int argc;
 631      char **argv;
 632 {
 633   /* If present, add SCSH-style meta-arguments from the top of the
 634      script file to the argument vector.  See the SCSH manual: "The
 635      meta argument" for more details.  */
 636   {
 637     char **new_argv = scm_get_meta_args (argc, argv);
 638
 639     if (new_argv)
 640       {
 641         argv = new_argv;
 642         argc = scm_count_argv (new_argv);
 643       }
 644   }
 645
 646   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv))));
 647 }
 648
 649
 650 void
 651 scm_init_script ()
 652 {
 653 #include "script.x"
 654 }