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 FILE        load Scheme source code from FILE\n"
 365            "  -e FUNCTION    after reading script, apply FUNCTION to\n"
 366            "                 command line arguments\n"
 367            "  -ds            do -s script at this point\n"
 368            "  --debug        start with debugging evaluator and backtraces\n"
 369            "  --no-debug     start with normal evaluator\n"
 370            "                 Default is to enable debugging for interactive\n"
 371            "                 use, but not for `-s' and `-c'.\n"
 372            "  -q             inhibit loading of user init file\n"
 373            "  --emacs        enable Emacs protocol (experimental)\n"
 374            "  --use-srfi=LS  load SRFI modules for the SRFIs in LS,\n"
 375            "                 which is a list of numbers like \"2,13,14\"\n"
 376            "  -h, --help     display this help and exit\n"
 377            "  -v, --version  display version information and exit\n"
 378            "  \\              read arguments from following script lines\n"
 379            "\n"
 380            "Please report bugs to bug-guile@gnu.org\n",
 381            scm_usage_name);
 382
 383   if (fatal)
 384     exit (fatal);
 385 }
 386
 387
 388 /* Some symbols used by the command-line compiler.  */
 389 SCM_SYMBOL (sym_load, "load");
 390 SCM_SYMBOL (sym_eval_string, "eval-string");
 391 SCM_SYMBOL (sym_command_line, "command-line");
 392 SCM_SYMBOL (sym_begin, "begin");
 393 SCM_SYMBOL (sym_turn_on_debugging, "turn-on-debugging");
 394 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 395 SCM_SYMBOL (sym_top_repl, "top-repl");
 396 SCM_SYMBOL (sym_quit, "quit");
 397 SCM_SYMBOL (sym_use_srfis, "use-srfis");
 398
 399
 400 /* Given an array of command-line switches, return a Scheme expression
 401    to carry out the actions specified by the switches.
 402
 403    If you told me this should have been written in Scheme, I'd
 404    probably agree.  I'd say I didn't feel comfortable doing that in
 405    the present system.  You'd say, well, fix the system so you are
 406    comfortable doing that.  I'd agree again.  *shrug*
 407  */
 408
 409 static char guile[] = "guile";
 410
 411 SCM
 412 scm_compile_shell_switches (int argc, char **argv)
 413 {
 414   SCM tail = SCM_EOL;           /* We accumulate the list backwards,
 415                                    and then reverse! it before we
 416                                    return it.  */
 417   SCM do_script = SCM_EOL;      /* The element of the list containing
 418                                    the "load" command, in case we get
 419                                    the "-ds" switch.  */
 420   SCM entry_point = SCM_EOL;    /* for -e switch */
 421   int interactive = 1;          /* Should we go interactive when done? */
 422   int inhibit_user_init = 0;    /* Don't load user init file */
 423   int use_emacs_interface = 0;
 424   int turn_on_debugging = 0;
 425   int dont_turn_on_debugging = 0;
 426
 427   int i;
 428   char *argv0 = guile;
 429
 430   if (argc > 0)
 431     {
 432       argv0 = argv[0];
 433       scm_usage_name = strrchr (argv[0], '/');
 434       if (! scm_usage_name)
 435         scm_usage_name = argv[0];
 436       else
 437         scm_usage_name++;
 438     }
 439   if (! scm_usage_name)
 440     scm_usage_name = guile;
 441
 442   for (i = 1; i < argc; i++)
 443     {
 444       if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
 445         {
 446           if ((argv[i][0] == '-') && (++i >= argc))
 447             scm_shell_usage (1, "missing argument to `-s' switch");
 448
 449           /* If we specified the -ds option, do_script points to the
 450              cdr of an expression like (load #f); we replace the car
 451              (i.e., the #f) with the script name.  */
 452           if (!SCM_NULLP (do_script))
 453             {
 454               SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
 455               do_script = SCM_EOL;
 456             }
 457           else
 458             /* Construct an application of LOAD to the script name.  */
 459             tail = scm_cons (scm_cons2 (sym_load,
 460                                         scm_makfrom0str (argv[i]),
 461                                         SCM_EOL),
 462                                tail);
 463           argv0 = argv[i];
 464           i++;
 465           interactive = 0;
 466           break;
 467         }
 468
 469       else if (! strcmp (argv[i], "-c")) /* evaluate expr */
 470         {
 471           if (++i >= argc)
 472             scm_shell_usage (1, "missing argument to `-c' switch");
 473           tail = scm_cons (scm_cons2 (sym_eval_string,
 474                                       scm_makfrom0str (argv[i]),
 475                                       SCM_EOL),
 476                            tail);
 477           i++;
 478           interactive = 0;
 479           break;
 480         }
 481
 482       else if (! strcmp (argv[i], "--")) /* end args; go interactive */
 483         {
 484           i++;
 485           break;
 486         }
 487
 488       else if (! strcmp (argv[i], "-l")) /* load a file */
 489         {
 490           if (++i < argc)
 491             tail = scm_cons (scm_cons2 (sym_load,
 492                                         scm_makfrom0str (argv[i]),
 493                                         SCM_EOL),
 494                              tail);
 495           else
 496             scm_shell_usage (1, "missing argument to `-l' switch");
 497         }
 498
 499       else if (! strcmp (argv[i], "-e")) /* entry point */
 500         {
 501           if (++i < argc)
 502             entry_point = scm_c_read_string (argv[i]);
 503           else
 504             scm_shell_usage (1, "missing argument to `-e' switch");
 505         }
 506
 507       else if (! strcmp (argv[i], "-ds")) /* do script here */
 508         {
 509           /* We put a dummy "load" expression, and let the -s put the
 510              filename in.  */
 511           if (!SCM_NULLP (do_script))
 512             scm_shell_usage (1, "the -ds switch may only be specified once");
 513           do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
 514           tail = scm_cons (scm_cons (sym_load, do_script),
 515                            tail);
 516         }
 517
 518       else if (! strcmp (argv[i], "--debug"))
 519         {
 520           turn_on_debugging = 1;
 521           dont_turn_on_debugging = 0;
 522         }
 523
 524       else if (! strcmp (argv[i], "--no-debug"))
 525         {
 526           dont_turn_on_debugging = 1;
 527           turn_on_debugging = 0;
 528         }
 529
 530       else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
 531         use_emacs_interface = 1;
 532
 533       else if (! strcmp (argv[i], "-q")) /* don't load user init */
 534         inhibit_user_init = 1;
 535
 536       else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
 537         {
 538           SCM srfis = SCM_EOL;  /* List of requested SRFIs.  */
 539           char * p = argv[i] + 11;
 540           while (*p)
 541             {
 542               long num;
 543               char * end;
 544
 545               num = strtol (p, &end, 10);
 546               if (end - p > 0)
 547                 {
 548                   srfis = scm_cons (scm_from_long (num), srfis);
 549                   if (*end)
 550                     {
 551                       if (*end == ',')
 552                         p = end + 1;
 553                       else
 554                         scm_shell_usage (1, "invalid SRFI specification");
 555                     }
 556                   else
 557                     break;
 558                 }
 559               else
 560                 scm_shell_usage (1, "invalid SRFI specification");
 561             }
 562           if (scm_ilength (srfis) <= 0)
 563             scm_shell_usage (1, "invalid SRFI specification");
 564           srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
 565           tail = scm_cons (scm_list_2 (sym_use_srfis,
 566                                        scm_list_2 (scm_sym_quote, srfis)),
 567                            tail);
 568         }
 569
 570       else if (! strcmp (argv[i], "-h")
 571                || ! strcmp (argv[i], "--help"))
 572         {
 573           scm_shell_usage (0, 0);
 574           exit (0);
 575         }
 576
 577       else if (! strcmp (argv[i], "-v")
 578                || ! strcmp (argv[i], "--version"))
 579         {
 580           /* Print version number.  */
 581           printf ("Guile %s\n"
 582                   "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002 Free Software Foundation\n"
 583                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 584                   "certain other uses are permitted as well.  For details, see the file\n"
 585                   "`COPYING', which is included in the Guile distribution.\n"
 586                   "There is no warranty, to the extent permitted by law.\n",
 587                   scm_to_locale_string (scm_version ()));
 588           exit (0);
 589         }
 590
 591       else
 592         {
 593           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 594                    scm_usage_name, argv[i]);
 595           scm_shell_usage (1, 0);
 596         }
 597     }
 598
 599   /* Check to make sure the -ds got a -s. */
 600   if (!SCM_NULLP (do_script))
 601     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 602
 603   /* Make any remaining arguments available to the
 604      script/command/whatever.  */
 605   scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
 606
 607   /* If the --emacs switch was set, now is when we process it.  */
 608   scm_c_define ("use-emacs-interface", scm_from_bool (use_emacs_interface));
 609
 610   /* Handle the `-e' switch, if it was specified.  */
 611   if (!SCM_NULLP (entry_point))
 612     tail = scm_cons (scm_cons2 (entry_point,
 613                                 scm_cons (sym_command_line, SCM_EOL),
 614                                 SCM_EOL),
 615                        tail);
 616
 617   /* If we didn't end with a -c or a -s, start the repl.  */
 618   if (interactive)
 619     {
 620       tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
 621     }
 622   else
 623     {
 624       /* After doing all the other actions prescribed by the command line,
 625          quit.  */
 626       tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
 627                        tail);
 628     }
 629
 630   /* After the following line, actions will be added to the front. */
 631   tail = scm_reverse_x (tail, SCM_UNDEFINED);
 632
 633   /* If we didn't end with a -c or a -s and didn't supply a -q, load
 634      the user's customization file.  */
 635   if (interactive && !inhibit_user_init)
 636     {
 637       tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
 638     }
 639
 640   /* If debugging was requested, or we are interactive and debugging
 641      was not explicitly turned off, turn on debugging. */
 642   if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
 643     {
 644       tail = scm_cons (scm_cons (sym_turn_on_debugging, SCM_EOL), tail);
 645     }
 646
 647   {
 648     SCM val = scm_cons (sym_begin, tail);
 649
 650 #if 0
 651     scm_write (val, SCM_UNDEFINED);
 652     scm_newline (SCM_UNDEFINED);
 653 #endif
 654
 655     return val;
 656   }
 657 }
 658
 659
 660 void
 661 scm_shell (int argc, char **argv)
 662 {
 663   /* If present, add SCSH-style meta-arguments from the top of the
 664      script file to the argument vector.  See the SCSH manual: "The
 665      meta argument" for more details.  */
 666   {
 667     char **new_argv = scm_get_meta_args (argc, argv);
 668
 669     if (new_argv)
 670       {
 671         argv = new_argv;
 672         argc = scm_count_argv (new_argv);
 673       }
 674   }
 675
 676   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
 677                                      scm_current_module ())));
 678 }
 679
 680
 681 void
 682 scm_init_script ()
 683 {
 684 #include "libguile/script.x"
 685 }
 686
 687 /*
 688   Local Variables:
 689   c-file-style: "gnu"
 690   End:
 691 */