libguile/script.c

   1 /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000 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 <ctype.h>
  49 #include "libguile/_scm.h"
  50 #include "libguile/gh.h"
  51 #include "libguile/load.h"
  52 #include "libguile/version.h"
  53
  54 #include "libguile/validate.h"
  55 #include "libguile/script.h"
  56
  57 #ifdef HAVE_STRING_H
  58 #include <string.h>
  59 #endif
  60
  61 #ifdef HAVE_UNISTD_H
  62 #include <unistd.h>             /* for X_OK define */
  63 #endif
  64
  65 /* Concatentate str2 onto str1 at position n and return concatenated
  66    string if file exists; 0 otherwise. */
  67
  68 static char *
  69 scm_cat_path (char *str1, const char *str2, long n)
  70 {
  71   if (!n)
  72     n = strlen (str2);
  73   if (str1)
  74     {
  75       long len = strlen (str1);
  76       str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1));
  77       if (!str1)
  78         return 0L;
  79       strncat (str1 + len, str2, n);
  80       return str1;
  81     }
  82   str1 = (char *) malloc ((scm_sizet) (n + 1));
  83   if (!str1)
  84     return 0L;
  85   str1[0] = 0;
  86   strncat (str1, str2, n);
  87   return str1;
  88 }
  89
  90 #if 0
  91 static char *
  92 scm_try_path (char *path)
  93 {
  94   FILE *f;
  95   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  96   if (!path)
  97     return 0L;
  98   SCM_SYSCALL (f = fopen (path, "r");
  99     );
 100   if (f)
 101     {
 102       fclose (f);
 103       return path;
 104     }
 105   free (path);
 106   return 0L;
 107 }
 108
 109 static char *
 110 scm_sep_init_try (char *path, const char *sep, const char *initname)
 111 {
 112   if (path)
 113     path = scm_cat_path (path, sep, 0L);
 114   if (path)
 115     path = scm_cat_path (path, initname, 0L);
 116   return scm_try_path (path);
 117 }
 118 #endif
 119
 120 #ifndef LINE_INCREMENTORS
 121 #define LINE_INCREMENTORS  '\n'
 122 #ifdef MSDOS
 123 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 124 #else
 125 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 126 #endif /* def MSDOS */
 127 #endif /* ndef LINE_INCREMENTORS */
 128
 129 #ifndef MAXPATHLEN
 130 #define MAXPATHLEN 80
 131 #endif /* ndef MAXPATHLEN */
 132 #ifndef X_OK
 133 #define X_OK 1
 134 #endif /* ndef X_OK */
 135
 136 char *
 137 scm_find_executable (const char *name)
 138 {
 139   char tbuf[MAXPATHLEN];
 140   int i = 0;
 141   FILE *f;
 142
 143   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 144   if (access (name, X_OK))
 145     return 0L;
 146   f = fopen (name, "r");
 147   if (!f)
 148     return 0L;
 149   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 150     {
 151       while (1)
 152         switch (tbuf[i++] = fgetc (f))
 153           {
 154           case /*WHITE_SPACES */ ' ':
 155           case '\t':
 156           case '\r':
 157           case '\f':
 158           case EOF:
 159             tbuf[--i] = 0;
 160             fclose (f);
 161             return scm_cat_path (0L, tbuf, 0L);
 162           }
 163     }
 164   fclose (f);
 165   return scm_cat_path (0L, name, 0L);
 166 }
 167
 168
 169 /* Read a \nnn-style escape.  We've just read the backslash.  */
 170 static int
 171 script_get_octal (FILE *f)
 172 #define FUNC_NAME "script_get_octal"
 173 {
 174   int i;
 175   int value = 0;
 176
 177   for (i = 0; i < 3; i++)
 178     {
 179       int c = getc (f);
 180       if ('0' <= c && c <= '7')
 181         value = (value * 8) + (c - '0');
 182       else
 183         SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
 184                         SCM_EOL);
 185     }
 186   return value;
 187 }
 188 #undef FUNC_NAME
 189
 190
 191 static int
 192 script_get_backslash (FILE *f)
 193 #define FUNC_NAME "script_get_backslash"
 194 {
 195   int c = getc (f);
 196
 197   switch (c)
 198     {
 199     case 'a': return '\a';
 200     case 'b': return '\b';
 201     case 'f': return '\f';
 202     case 'n': return '\n';
 203     case 'r': return '\r';
 204     case 't': return '\t';
 205     case 'v': return '\v';
 206
 207     case '\\':
 208     case ' ':
 209     case '\t':
 210     case '\n':
 211       return c;
 212
 213     case '0': case '1': case '2': case '3':
 214     case '4': case '5': case '6': case '7':
 215       ungetc (c, f);
 216       return script_get_octal (f);
 217
 218     case EOF:
 219       SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
 220       return 0; /* not reached? */
 221
 222     default:
 223       SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
 224       return 0; /* not reached? */
 225     }
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 static char *
 231 script_read_arg (FILE *f)
 232 #define FUNC_NAME "script_read_arg"
 233 {
 234   int size = 7;
 235   char *buf = malloc (size + 1);
 236   int len = 0;
 237
 238   if (! buf)
 239     return 0;
 240
 241   for (;;)
 242     {
 243       int c = getc (f);
 244       switch (c)
 245         {
 246         case '\\':
 247           c = script_get_backslash (f);
 248           /* The above produces a new character to add to the argument.
 249              Fall through.  */
 250         default:
 251           if (len >= size)
 252             {
 253               size = (size + 1) * 2;
 254               buf = realloc (buf, size);
 255               if (! buf)
 256                 return 0;
 257             }
 258           buf[len++] = c;
 259           break;
 260
 261         case '\n':
 262           /* This may terminate an arg now, but it will terminate the
 263              entire list next time through.  */
 264           ungetc ('\n', f);
 265         case EOF:
 266           if (len == 0)
 267             {
 268               free (buf);
 269               return 0;
 270             }
 271           /* Otherwise, those characters terminate the argument; fall
 272              through.  */
 273         case ' ':
 274           buf[len] = '\0';
 275           return buf;
 276
 277         case '\t':
 278           free (buf);
 279           SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
 280           return 0; /* not reached? */
 281         }
 282     }
 283 }
 284 #undef FUNC_NAME
 285
 286
 287 static int
 288 script_meta_arg_P (char *arg)
 289 {
 290   if ('\\' != arg[0])
 291     return 0L;
 292 #ifdef MSDOS
 293   return !arg[1];
 294 #else
 295   switch (arg[1])
 296     {
 297     case 0:
 298     case '%':
 299     case WHITE_SPACES:
 300       return !0;
 301     default:
 302       return 0L;
 303     }
 304 #endif
 305 }
 306
 307 char **
 308 scm_get_meta_args (int argc, char **argv)
 309 {
 310   int nargc = argc, argi = 1, nargi = 1;
 311   char *narg, **nargv;
 312   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 313     return 0L;
 314   if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
 315       return 0L;
 316   nargv[0] = argv[0];
 317   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 318     {
 319       FILE *f = fopen (argv[++argi], "r");
 320       if (f)
 321         {
 322           nargc--;              /* to compensate for replacement of '\\' */
 323           while (1)
 324             switch (getc (f))
 325               {
 326               case EOF:
 327                 return 0L;
 328               default:
 329                 continue;
 330               case '\n':
 331                 goto found_args;
 332               }
 333         found_args:
 334           while ((narg = script_read_arg (f)))
 335             if (!(nargv = (char **) realloc (nargv,
 336                                              (1 + ++nargc) * sizeof (char *))))
 337                 return 0L;
 338             else
 339               nargv[nargi++] = narg;
 340           fclose (f);
 341           nargv[nargi++] = argv[argi++];
 342         }
 343     }
 344   while (argi <= argc)
 345     nargv[nargi++] = argv[argi++];
 346   return nargv;
 347 }
 348
 349 int
 350 scm_count_argv (char **argv)
 351 {
 352   int argc = 0;
 353   while (argv[argc])
 354     argc++;
 355   return argc;
 356 }
 357
 358
 359 /* For use in error messages.  */
 360 char *scm_usage_name = 0;
 361
 362 void
 363 scm_shell_usage (int fatal, char *message)
 364 {
 365   if (message)
 366     fprintf (stderr, "%s\n", message);
 367
 368   fprintf (stderr,
 369            "Usage: %s OPTION ...\n"
 370            "Evaluate Scheme code, interactively or from a script.\n"
 371            "\n"
 372            "  -s SCRIPT      load Scheme source code from FILE, and exit\n"
 373            "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
 374            "  --             stop scanning arguments; run interactively\n"
 375            "The above switches stop argument processing, and pass all\n"
 376            "remaining arguments as the value of (command-line).\n"
 377            "\n"
 378            "  -l FILE        load Scheme source code from FILE\n"
 379            "  -e FUNCTION    after reading script, apply FUNCTION to\n"
 380            "                 command line arguments\n"
 381            "  -ds            do -s script at this point\n"
 382            "  --debug        start with debugging evaluator and backtraces\n"
 383            "  -q             inhibit loading of user init file\n"
 384            "  --emacs        enable Emacs protocol (experimental)\n"
 385            "  -h, --help     display this help and exit\n"
 386            "  -v, --version  display version information and exit\n"
 387            "  \\              read arguments from following script lines\n",
 388            scm_usage_name);
 389
 390   if (fatal)
 391     exit (fatal);
 392 }
 393
 394
 395 /* Some symbols used by the command-line compiler.  */
 396 SCM_SYMBOL (sym_load, "load");
 397 SCM_SYMBOL (sym_eval_string, "eval-string");
 398 SCM_SYMBOL (sym_command_line, "command-line");
 399 SCM_SYMBOL (sym_begin, "begin");
 400 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 401 SCM_SYMBOL (sym_top_repl, "top-repl");
 402 SCM_SYMBOL (sym_quit, "quit");
 403
 404
 405 /* Given an array of command-line switches, return a Scheme expression
 406    to carry out the actions specified by the switches.
 407
 408    If you told me this should have been written in Scheme, I'd
 409    probably agree.  I'd say I didn't feel comfortable doing that in
 410    the present system.  You'd say, well, fix the system so you are
 411    comfortable doing that.  I'd agree again.  *shrug*
 412
 413    We load the ice-9 system from here.  It might be nicer if the
 414    libraries initialized from the inner_main function in guile.c (which
 415    will be auto-generated eventually) could assume ice-9 were already
 416    loaded.  Then again, it might be nice if ice-9 could assume that
 417    certain libraries were already loaded.  The solution is to break up
 418    ice-9 into modules which can be frozen and statically linked like any
 419    other module.  Then all the modules can describe their dependencies in
 420    the usual way, and the auto-generated inner_main will do the right
 421    thing. */
 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 (! strcmp (argv[i], "-h")
 544                || ! strcmp (argv[i], "--help"))
 545         {
 546           scm_shell_usage (0, 0);
 547           exit (0);
 548         }
 549
 550       else if (! strcmp (argv[i], "-v")
 551                || ! strcmp (argv[i], "--version"))
 552         {
 553           /* Print version number.  */
 554           printf ("Guile %s\n"
 555                   "Copyright (c) 1995, 1996, 1997, 2000 Free Software Foundation\n"
 556                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 557                   "certain other uses are permitted as well.  For details, see the file\n"
 558                   "`COPYING', which is included in the Guile distribution.\n"
 559                   "There is no warranty, to the extent permitted by law.\n",
 560                   SCM_STRING_CHARS (scm_version ()));
 561           exit (0);
 562         }
 563
 564       else
 565         {
 566           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 567                    scm_usage_name, argv[i]);
 568           scm_shell_usage (1, 0);
 569         }
 570     }
 571
 572   /* Check to make sure the -ds got a -s. */
 573   if (!SCM_NULLP (do_script))
 574     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 575
 576   /* Make any remaining arguments available to the
 577      script/command/whatever.  */
 578   scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
 579
 580   /* If the --emacs switch was set, now is when we process it.  */
 581   scm_sysintern ("use-emacs-interface", SCM_BOOL (use_emacs_interface));
 582
 583   /* Handle the `-e' switch, if it was specified.  */
 584   if (!SCM_NULLP (entry_point))
 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 (int argc, char **argv)
 630 {
 631   /* If present, add SCSH-style meta-arguments from the top of the
 632      script file to the argument vector.  See the SCSH manual: "The
 633      meta argument" for more details.  */
 634   {
 635     char **new_argv = scm_get_meta_args (argc, argv);
 636
 637     if (new_argv)
 638       {
 639         argv = new_argv;
 640         argc = scm_count_argv (new_argv);
 641       }
 642   }
 643
 644   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
 645                                      scm_the_root_module ())));
 646 }
 647
 648
 649 void
 650 scm_init_script ()
 651 {
 652 #ifndef SCM_MAGIC_SNARFER
 653 #include "libguile/script.x"
 654 #endif
 655 }
 656
 657 /*
 658   Local Variables:
 659   c-file-style: "gnu"
 660   End:
 661 */