1 /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
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.
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17 /* "script.c" argv tricks for `#!' scripts.
18 Authors: Aubrey Jaffer and Jim Blandy */
28 #include "libguile/_scm.h"
29 #include "libguile/gh.h"
30 #include "libguile/load.h"
31 #include "libguile/version.h"
33 #include "libguile/validate.h"
34 #include "libguile/script.h"
41 #include <unistd.h> /* for X_OK define */
48 /* Concatentate str2 onto str1 at position n and return concatenated
49 string if file exists; 0 otherwise. */
52 scm_cat_path (char *str1, const char *str2, long n)
58 size_t len = strlen (str1);
59 str1 = (char *) realloc (str1, (size_t) (len + n + 1));
62 strncat (str1 + len, str2, n);
65 str1 = (char *) scm_malloc ((size_t) (n + 1));
69 strncat (str1, str2, n);
75 scm_try_path (char *path)
78 /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
81 SCM_SYSCALL (f = fopen (path, "r");
93 scm_sep_init_try (char *path, const char *sep, const char *initname)
96 path = scm_cat_path (path, sep, 0L);
98 path = scm_cat_path (path, initname, 0L);
99 return scm_try_path (path);
103 #ifndef LINE_INCREMENTORS
104 #define LINE_INCREMENTORS '\n'
106 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26
108 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
109 #endif /* def MSDOS */
110 #endif /* ndef LINE_INCREMENTORS */
113 #define MAXPATHLEN 80
114 #endif /* ndef MAXPATHLEN */
117 #endif /* ndef X_OK */
120 scm_find_executable (const char *name)
122 char tbuf[MAXPATHLEN];
126 /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
127 if (access (name, X_OK))
129 f = fopen (name, "r");
132 if ((fgetc (f) == '#') && (fgetc (f) == '!'))
135 switch (c = fgetc (f))
137 case /*WHITE_SPACES */ ' ':
144 return scm_cat_path (0L, tbuf, 0L);
151 return scm_cat_path (0L, name, 0L);
155 /* Read a \nnn-style escape. We've just read the backslash. */
157 script_get_octal (FILE *f)
158 #define FUNC_NAME "script_get_octal"
163 for (i = 0; i < 3; i++)
166 if ('0' <= c && c <= '7')
167 value = (value * 8) + (c - '0');
169 SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
178 script_get_backslash (FILE *f)
179 #define FUNC_NAME "script_get_backslash"
185 case 'a': return '\a';
186 case 'b': return '\b';
187 case 'f': return '\f';
188 case 'n': return '\n';
189 case 'r': return '\r';
190 case 't': return '\t';
191 case 'v': return '\v';
199 case '0': case '1': case '2': case '3':
200 case '4': case '5': case '6': case '7':
202 return script_get_octal (f);
205 SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
206 return 0; /* not reached? */
209 SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
210 return 0; /* not reached? */
217 script_read_arg (FILE *f)
218 #define FUNC_NAME "script_read_arg"
221 char *buf = scm_malloc (size + 1);
233 c = script_get_backslash (f);
234 /* The above produces a new character to add to the argument.
239 size = (size + 1) * 2;
240 buf = realloc (buf, size);
248 /* This may terminate an arg now, but it will terminate the
249 entire list next time through. */
257 /* Otherwise, those characters terminate the argument; fall
265 SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
266 return 0; /* not reached? */
274 script_meta_arg_P (char *arg)
294 scm_get_meta_args (int argc, char **argv)
296 int nargc = argc, argi = 1, nargi = 1;
298 if (!(argc > 2 && script_meta_arg_P (argv[1])))
300 if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
303 while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
305 FILE *f = fopen (argv[++argi], "r");
308 nargc--; /* to compensate for replacement of '\\' */
320 while ((narg = script_read_arg (f)))
321 if (!(nargv = (char **) realloc (nargv,
322 (1 + ++nargc) * sizeof (char *))))
325 nargv[nargi++] = narg;
327 nargv[nargi++] = argv[argi++];
331 nargv[nargi++] = argv[argi++];
336 scm_count_argv (char **argv)
345 /* For use in error messages. */
346 char *scm_usage_name = 0;
349 scm_shell_usage (int fatal, char *message)
351 FILE *fp = (fatal ? stderr : stdout);
354 fprintf (fp, "%s\n", message);
357 "Usage: %s OPTION ...\n"
358 "Evaluate Scheme code, interactively or from a script.\n"
360 " [-s] FILE load Scheme source code from FILE, and exit\n"
361 " -c EXPR evalute Scheme expression EXPR, and exit\n"
362 " -- stop scanning arguments; run interactively\n"
363 "The above switches stop argument processing, and pass all\n"
364 "remaining arguments as the value of (command-line).\n"
365 "If FILE begins with `-' the -s switch is mandatory.\n"
367 " -L DIRECTORY add DIRECTORY to the front of the module load path\n"
368 " -l FILE load Scheme source code from FILE\n"
369 " -e FUNCTION after reading script, apply FUNCTION to\n"
370 " command line arguments\n"
371 " -ds do -s script at this point\n"
372 " --debug start with debugging evaluator and backtraces\n"
373 " --no-debug start with normal evaluator\n"
374 " Default is to enable debugging for interactive\n"
375 " use, but not for `-s' and `-c'.\n"
376 " -q inhibit loading of user init file\n"
377 " --emacs enable Emacs protocol (experimental)\n"
378 " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n"
379 " which is a list of numbers like \"2,13,14\"\n"
380 " -h, --help display this help and exit\n"
381 " -v, --version display version information and exit\n"
382 " \\ read arguments from following script lines\n"
384 "Please report bugs to bug-guile@gnu.org\n",
392 /* Some symbols used by the command-line compiler. */
393 SCM_SYMBOL (sym_load, "load");
394 SCM_SYMBOL (sym_eval_string, "eval-string");
395 SCM_SYMBOL (sym_command_line, "command-line");
396 SCM_SYMBOL (sym_begin, "begin");
397 SCM_SYMBOL (sym_turn_on_debugging, "turn-on-debugging");
398 SCM_SYMBOL (sym_load_user_init, "load-user-init");
399 SCM_SYMBOL (sym_top_repl, "top-repl");
400 SCM_SYMBOL (sym_quit, "quit");
401 SCM_SYMBOL (sym_use_srfis, "use-srfis");
402 SCM_SYMBOL (sym_load_path, "%load-path");
403 SCM_SYMBOL (sym_set_x, "set!");
404 SCM_SYMBOL (sym_cons, "cons");
405 SCM_SYMBOL (sym_at, "@");
406 SCM_SYMBOL (sym_atat, "@@");
407 SCM_SYMBOL (sym_main, "main");
409 /* Given an array of command-line switches, return a Scheme expression
410 to carry out the actions specified by the switches.
412 If you told me this should have been written in Scheme, I'd
413 probably agree. I'd say I didn't feel comfortable doing that in
414 the present system. You'd say, well, fix the system so you are
415 comfortable doing that. I'd agree again. *shrug*
418 static char guile[] = "guile";
421 all_symbols (SCM list)
423 while (scm_is_pair (list))
425 if (!scm_is_symbol (SCM_CAR (list)))
427 list = SCM_CDR (list);
433 scm_compile_shell_switches (int argc, char **argv)
435 SCM tail = SCM_EOL; /* We accumulate the list backwards,
436 and then reverse! it before we
438 SCM do_script = SCM_EOL; /* The element of the list containing
439 the "load" command, in case we get
441 SCM entry_point = SCM_EOL; /* for -e switch */
442 SCM user_load_path = SCM_EOL; /* for -L switch */
443 int interactive = 1; /* Should we go interactive when done? */
444 int inhibit_user_init = 0; /* Don't load user init file */
445 int use_emacs_interface = 0;
446 int turn_on_debugging = 0;
447 int dont_turn_on_debugging = 0;
455 scm_usage_name = strrchr (argv[0], '/');
456 if (! scm_usage_name)
457 scm_usage_name = argv[0];
461 if (! scm_usage_name)
462 scm_usage_name = guile;
464 for (i = 1; i < argc; i++)
466 if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
468 if ((argv[i][0] == '-') && (++i >= argc))
469 scm_shell_usage (1, "missing argument to `-s' switch");
471 /* If we specified the -ds option, do_script points to the
472 cdr of an expression like (load #f); we replace the car
473 (i.e., the #f) with the script name. */
474 if (!scm_is_null (do_script))
476 SCM_SETCAR (do_script, scm_from_locale_string (argv[i]));
480 /* Construct an application of LOAD to the script name. */
481 tail = scm_cons (scm_cons2 (sym_load,
482 scm_from_locale_string (argv[i]),
491 else if (! strcmp (argv[i], "-c")) /* evaluate expr */
494 scm_shell_usage (1, "missing argument to `-c' switch");
495 tail = scm_cons (scm_cons2 (sym_eval_string,
496 scm_from_locale_string (argv[i]),
504 else if (! strcmp (argv[i], "--")) /* end args; go interactive */
510 else if (! strcmp (argv[i], "-l")) /* load a file */
513 tail = scm_cons (scm_cons2 (sym_load,
514 scm_from_locale_string (argv[i]),
518 scm_shell_usage (1, "missing argument to `-l' switch");
521 else if (! strcmp (argv[i], "-L")) /* add to %load-path */
525 scm_cons (scm_list_3 (sym_set_x,
527 scm_list_3 (sym_cons,
528 scm_from_locale_string (argv[i]),
532 scm_shell_usage (1, "missing argument to `-L' switch");
535 else if (! strcmp (argv[i], "-e")) /* entry point */
540 = scm_open_input_string (scm_from_locale_string (argv[i]));
541 SCM arg1 = scm_read (port);
542 SCM arg2 = scm_read (port);
544 /* Recognize syntax of certain versions of Guile 1.4 and
545 transform to (@ MODULE-NAME FUNC).
547 if (scm_is_false (scm_eof_object_p (arg2)))
548 entry_point = scm_list_3 (sym_at, arg1, arg2);
549 else if (scm_is_pair (arg1)
550 && !(scm_is_eq (SCM_CAR (arg1), sym_at)
551 || scm_is_eq (SCM_CAR (arg1), sym_atat))
552 && all_symbols (arg1))
553 entry_point = scm_list_3 (sym_at, arg1, sym_main);
558 scm_shell_usage (1, "missing argument to `-e' switch");
561 else if (! strcmp (argv[i], "-ds")) /* do script here */
563 /* We put a dummy "load" expression, and let the -s put the
565 if (!scm_is_null (do_script))
566 scm_shell_usage (1, "the -ds switch may only be specified once");
567 do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
568 tail = scm_cons (scm_cons (sym_load, do_script),
572 else if (! strcmp (argv[i], "--debug"))
574 turn_on_debugging = 1;
575 dont_turn_on_debugging = 0;
578 else if (! strcmp (argv[i], "--no-debug"))
580 dont_turn_on_debugging = 1;
581 turn_on_debugging = 0;
584 else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
585 use_emacs_interface = 1;
587 else if (! strcmp (argv[i], "-q")) /* don't load user init */
588 inhibit_user_init = 1;
590 else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
592 SCM srfis = SCM_EOL; /* List of requested SRFIs. */
593 char * p = argv[i] + 11;
599 num = strtol (p, &end, 10);
602 srfis = scm_cons (scm_from_long (num), srfis);
608 scm_shell_usage (1, "invalid SRFI specification");
614 scm_shell_usage (1, "invalid SRFI specification");
616 if (scm_ilength (srfis) <= 0)
617 scm_shell_usage (1, "invalid SRFI specification");
618 srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
619 tail = scm_cons (scm_list_2 (sym_use_srfis,
620 scm_list_2 (scm_sym_quote, srfis)),
624 else if (! strcmp (argv[i], "-h")
625 || ! strcmp (argv[i], "--help"))
627 scm_shell_usage (0, 0);
631 else if (! strcmp (argv[i], "-v")
632 || ! strcmp (argv[i], "--version"))
634 /* Print version number. */
636 "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation\n"
637 "Guile may be distributed under the terms of the GNU General Public Licence;\n"
638 "certain other uses are permitted as well. For details, see the file\n"
639 "`COPYING', which is included in the Guile distribution.\n"
640 "There is no warranty, to the extent permitted by law.\n",
641 scm_to_locale_string (scm_version ()));
647 fprintf (stderr, "%s: Unrecognized switch `%s'\n",
648 scm_usage_name, argv[i]);
649 scm_shell_usage (1, 0);
653 /* Check to make sure the -ds got a -s. */
654 if (!scm_is_null (do_script))
655 scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
657 /* Make any remaining arguments available to the
658 script/command/whatever. */
659 scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
661 /* If the --emacs switch was set, now is when we process it. */
662 scm_c_define ("use-emacs-interface", scm_from_bool (use_emacs_interface));
664 /* Handle the `-e' switch, if it was specified. */
665 if (!scm_is_null (entry_point))
666 tail = scm_cons (scm_cons2 (entry_point,
667 scm_cons (sym_command_line, SCM_EOL),
671 /* If we didn't end with a -c or a -s, start the repl. */
674 tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
678 /* After doing all the other actions prescribed by the command line,
680 tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
684 /* After the following line, actions will be added to the front. */
685 tail = scm_reverse_x (tail, SCM_UNDEFINED);
687 /* add the user-specified load path here, so it won't be in effect
688 during the loading of the user's customization file. */
689 if(!scm_is_null(user_load_path))
691 tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) );
694 /* If we didn't end with a -c or a -s and didn't supply a -q, load
695 the user's customization file. */
696 if (interactive && !inhibit_user_init)
698 tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
701 /* If debugging was requested, or we are interactive and debugging
702 was not explicitly turned off, turn on debugging. */
703 if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
705 tail = scm_cons (scm_cons (sym_turn_on_debugging, SCM_EOL), tail);
709 SCM val = scm_cons (sym_begin, tail);
712 scm_write (val, SCM_UNDEFINED);
713 scm_newline (SCM_UNDEFINED);
722 scm_shell (int argc, char **argv)
724 /* If present, add SCSH-style meta-arguments from the top of the
725 script file to the argument vector. See the SCSH manual: "The
726 meta argument" for more details. */
728 char **new_argv = scm_get_meta_args (argc, argv);
733 argc = scm_count_argv (new_argv);
737 exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
738 scm_current_module ())));
745 #include "libguile/script.x"