libguile/script.c

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