libguile/script.c

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