libguile/script.c

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