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