libguile/script.c

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