1 /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 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 License
4 * as published by the Free Software Foundation; either version 3 of
5 * the License, or (at your option) any later version.
7 * This library is distributed in the hope that it will be useful, but
8 * 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
18 /* "script.c" argv tricks for `#!' scripts.
19 Authors: Aubrey Jaffer and Jim Blandy */
30 #include <version-etc.h>
32 #include "libguile/_scm.h"
33 #include "libguile/eval.h"
34 #include "libguile/feature.h"
35 #include "libguile/load.h"
36 #include "libguile/private-gc.h" /* scm_getenv_int */
37 #include "libguile/read.h"
38 #include "libguile/script.h"
39 #include "libguile/strings.h"
40 #include "libguile/strports.h"
41 #include "libguile/validate.h"
42 #include "libguile/version.h"
43 #include "libguile/vm.h"
50 #include <unistd.h> /* for X_OK define */
57 /* Concatentate str2 onto str1 at position n and return concatenated
58 string if file exists; 0 otherwise. */
61 scm_cat_path (char *str1
, const char *str2
, long n
)
67 size_t len
= strlen (str1
);
68 str1
= (char *) realloc (str1
, (size_t) (len
+ n
+ 1));
71 strncat (str1
+ len
, str2
, n
);
74 str1
= (char *) scm_malloc ((size_t) (n
+ 1));
78 strncat (str1
, str2
, n
);
84 scm_try_path (char *path
)
87 /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
90 SCM_SYSCALL (f
= fopen (path
, "r");
102 scm_sep_init_try (char *path
, const char *sep
, const char *initname
)
105 path
= scm_cat_path (path
, sep
, 0L);
107 path
= scm_cat_path (path
, initname
, 0L);
108 return scm_try_path (path
);
112 #ifndef LINE_INCREMENTORS
113 #define LINE_INCREMENTORS '\n'
115 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26
117 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
118 #endif /* def MSDOS */
119 #endif /* ndef LINE_INCREMENTORS */
122 #define MAXPATHLEN 80
123 #endif /* ndef MAXPATHLEN */
126 #endif /* ndef X_OK */
129 scm_find_executable (const char *name
)
131 char tbuf
[MAXPATHLEN
];
135 /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
136 if (access (name
, X_OK
))
138 f
= fopen (name
, "r");
141 if ((fgetc (f
) == '#') && (fgetc (f
) == '!'))
144 switch (c
= fgetc (f
))
146 case /*WHITE_SPACES */ ' ':
153 return scm_cat_path (0L, tbuf
, 0L);
160 return scm_cat_path (0L, name
, 0L);
164 /* Read a \nnn-style escape. We've just read the backslash. */
166 script_get_octal (FILE *f
)
167 #define FUNC_NAME "script_get_octal"
172 for (i
= 0; i
< 3; i
++)
175 if ('0' <= c
&& c
<= '7')
176 value
= (value
* 8) + (c
- '0');
178 SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
187 script_get_backslash (FILE *f
)
188 #define FUNC_NAME "script_get_backslash"
194 case 'a': return '\a';
195 case 'b': return '\b';
196 case 'f': return '\f';
197 case 'n': return '\n';
198 case 'r': return '\r';
199 case 't': return '\t';
200 case 'v': return '\v';
208 case '0': case '1': case '2': case '3':
209 case '4': case '5': case '6': case '7':
211 return script_get_octal (f
);
214 SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL
);
215 return 0; /* not reached? */
218 SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL
);
219 return 0; /* not reached? */
226 script_read_arg (FILE *f
)
227 #define FUNC_NAME "script_read_arg"
230 char *buf
= scm_malloc (size
+ 1);
242 c
= script_get_backslash (f
);
243 /* The above produces a new character to add to the argument.
248 size
= (size
+ 1) * 2;
249 buf
= realloc (buf
, size
);
257 /* This may terminate an arg now, but it will terminate the
258 entire list next time through. */
266 /* Otherwise, those characters terminate the argument; fall
274 SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL
);
275 return 0; /* not reached? */
283 script_meta_arg_P (char *arg
)
303 scm_get_meta_args (int argc
, char **argv
)
305 int nargc
= argc
, argi
= 1, nargi
= 1;
307 if (!(argc
> 2 && script_meta_arg_P (argv
[1])))
309 if (!(nargv
= (char **) scm_malloc ((1 + nargc
) * sizeof (char *))))
312 while (((argi
+ 1) < argc
) && (script_meta_arg_P (argv
[argi
])))
314 FILE *f
= fopen (argv
[++argi
], "r");
317 nargc
--; /* to compensate for replacement of '\\' */
329 while ((narg
= script_read_arg (f
)))
330 if (!(nargv
= (char **) realloc (nargv
,
331 (1 + ++nargc
) * sizeof (char *))))
334 nargv
[nargi
++] = narg
;
336 nargv
[nargi
++] = argv
[argi
++];
340 nargv
[nargi
++] = argv
[argi
++];
345 scm_count_argv (char **argv
)
354 /* For use in error messages. */
355 char *scm_usage_name
= 0;
358 scm_shell_usage (int fatal
, char *message
)
360 FILE *fp
= (fatal
? stderr
: stdout
);
363 fprintf (fp
, "%s\n", message
);
366 "Usage: %s [OPTION]... [FILE]...\n"
367 "Evaluate Scheme code, interactively or from a script.\n"
369 " [-s] FILE load Scheme source code from FILE, and exit\n"
370 " -c EXPR evalute Scheme expression EXPR, and exit\n"
371 " -- stop scanning arguments; run interactively\n\n"
372 "The above switches stop argument processing, and pass all\n"
373 "remaining arguments as the value of (command-line).\n"
374 "If FILE begins with `-' the -s switch is mandatory.\n"
376 " -L DIRECTORY add DIRECTORY to the front of the module load path\n"
377 " -x EXTENSION add EXTENSION to the front of the load extensions\n"
378 " -l FILE load Scheme source code from FILE\n"
379 " -e FUNCTION after reading script, apply FUNCTION to\n"
380 " command line arguments\n"
381 " -ds do -s script at this point\n"
382 " --debug start with debugging evaluator and backtraces\n"
383 " --no-debug start with normal evaluator\n"
384 " Default is to enable debugging for interactive\n"
385 " use, but not for `-s' and `-c'.\n"
386 " --auto-compile compile source files automatically\n"
387 " --no-auto-compile disable automatic source file compilation\n"
388 " Default is to enable auto-compilation of source\n"
390 " --listen[=P] Listen on a local port or a path for REPL clients.\n"
391 " If P is not given, the default is local port 37146.\n"
392 " -q inhibit loading of user init file\n"
393 " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n"
394 " which is a list of numbers like \"2,13,14\"\n"
395 " -h, --help display this help and exit\n"
396 " -v, --version display version information and exit\n"
397 " \\ read arguments from following script lines\n",
400 emit_bug_reporting_address ();
407 /* Some symbols used by the command-line compiler. */
408 SCM_SYMBOL (sym_load
, "load");
409 SCM_SYMBOL (sym_eval_string
, "eval-string");
410 SCM_SYMBOL (sym_command_line
, "command-line");
411 SCM_SYMBOL (sym_begin
, "begin");
412 SCM_SYMBOL (sym_load_user_init
, "load-user-init");
413 SCM_SYMBOL (sym_ice_9
, "ice-9");
414 SCM_SYMBOL (sym_top_repl
, "top-repl");
415 SCM_SYMBOL (sym_quit
, "quit");
416 SCM_SYMBOL (sym_use_srfis
, "use-srfis");
417 SCM_SYMBOL (sym_load_path
, "%load-path");
418 SCM_SYMBOL (sym_load_extensions
, "%load-extensions");
419 SCM_SYMBOL (sym_set_x
, "set!");
420 SCM_SYMBOL (sym_sys_load_should_auto_compile
, "%load-should-auto-compile");
421 SCM_SYMBOL (sym_cons
, "cons");
422 SCM_SYMBOL (sym_at
, "@");
423 SCM_SYMBOL (sym_atat
, "@@");
424 SCM_SYMBOL (sym_main
, "main");
426 /* Given an array of command-line switches, return a Scheme expression
427 to carry out the actions specified by the switches.
429 If you told me this should have been written in Scheme, I'd
430 probably agree. I'd say I didn't feel comfortable doing that in
431 the present system. You'd say, well, fix the system so you are
432 comfortable doing that. I'd agree again. *shrug*
435 static char guile
[] = "guile";
438 all_symbols (SCM list
)
440 while (scm_is_pair (list
))
442 if (!scm_is_symbol (SCM_CAR (list
)))
444 list
= SCM_CDR (list
);
450 scm_compile_shell_switches (int argc
, char **argv
)
452 SCM tail
= SCM_EOL
; /* We accumulate the list backwards,
453 and then reverse! it before we
455 SCM do_script
= SCM_EOL
; /* The element of the list containing
456 the "load" command, in case we get
458 SCM entry_point
= SCM_EOL
; /* for -e switch */
459 SCM user_load_path
= SCM_EOL
; /* for -L switch */
460 SCM user_extensions
= SCM_EOL
;/* for -x switch */
461 int interactive
= 1; /* Should we go interactive when done? */
462 int inhibit_user_init
= 0; /* Don't load user init file */
463 int turn_on_debugging
= 0;
464 int dont_turn_on_debugging
= 0;
472 scm_usage_name
= strrchr (argv
[0], '/');
473 if (! scm_usage_name
)
474 scm_usage_name
= argv
[0];
478 if (! scm_usage_name
)
479 scm_usage_name
= guile
;
481 for (i
= 1; i
< argc
; i
++)
483 if ((! strcmp (argv
[i
], "-s")) || (argv
[i
][0] != '-')) /* load script */
485 if ((argv
[i
][0] == '-') && (++i
>= argc
))
486 scm_shell_usage (1, "missing argument to `-s' switch");
488 /* If we specified the -ds option, do_script points to the
489 cdr of an expression like (load #f); we replace the car
490 (i.e., the #f) with the script name. */
491 if (!scm_is_null (do_script
))
493 SCM_SETCAR (do_script
, scm_from_locale_string (argv
[i
]));
497 /* Construct an application of LOAD to the script name. */
498 tail
= scm_cons (scm_cons2 (sym_load
,
499 scm_from_locale_string (argv
[i
]),
508 else if (! strcmp (argv
[i
], "-c")) /* evaluate expr */
511 scm_shell_usage (1, "missing argument to `-c' switch");
512 tail
= scm_cons (scm_cons2 (sym_eval_string
,
513 scm_from_locale_string (argv
[i
]),
521 else if (! strcmp (argv
[i
], "--")) /* end args; go interactive */
527 else if (! strcmp (argv
[i
], "-l")) /* load a file */
530 tail
= scm_cons (scm_cons2 (sym_load
,
531 scm_from_locale_string (argv
[i
]),
535 scm_shell_usage (1, "missing argument to `-l' switch");
538 else if (! strcmp (argv
[i
], "-L")) /* add to %load-path */
542 scm_cons (scm_list_3 (sym_set_x
,
544 scm_list_3 (sym_cons
,
545 scm_from_locale_string (argv
[i
]),
549 scm_shell_usage (1, "missing argument to `-L' switch");
552 else if (! strcmp (argv
[i
], "-x")) /* add to %load-extensions */
556 scm_cons (scm_list_3 (sym_set_x
,
558 scm_list_3 (sym_cons
,
559 scm_from_locale_string (argv
[i
]),
560 sym_load_extensions
)),
563 scm_shell_usage (1, "missing argument to `-x' switch");
566 else if (! strcmp (argv
[i
], "-e")) /* entry point */
571 = scm_open_input_string (scm_from_locale_string (argv
[i
]));
572 SCM arg1
= scm_read (port
);
573 SCM arg2
= scm_read (port
);
575 /* Recognize syntax of certain versions of Guile 1.4 and
576 transform to (@ MODULE-NAME FUNC).
578 if (scm_is_false (scm_eof_object_p (arg2
)))
579 entry_point
= scm_list_3 (sym_at
, arg1
, arg2
);
580 else if (scm_is_pair (arg1
)
581 && !(scm_is_eq (SCM_CAR (arg1
), sym_at
)
582 || scm_is_eq (SCM_CAR (arg1
), sym_atat
))
583 && all_symbols (arg1
))
584 entry_point
= scm_list_3 (sym_at
, arg1
, sym_main
);
589 scm_shell_usage (1, "missing argument to `-e' switch");
592 else if (! strcmp (argv
[i
], "-ds")) /* do script here */
594 /* We put a dummy "load" expression, and let the -s put the
596 if (!scm_is_null (do_script
))
597 scm_shell_usage (1, "the -ds switch may only be specified once");
598 do_script
= scm_cons (SCM_BOOL_F
, SCM_EOL
);
599 tail
= scm_cons (scm_cons (sym_load
, do_script
),
603 else if (! strcmp (argv
[i
], "--debug"))
605 turn_on_debugging
= 1;
606 dont_turn_on_debugging
= 0;
609 else if (! strcmp (argv
[i
], "--no-debug"))
611 dont_turn_on_debugging
= 1;
612 turn_on_debugging
= 0;
615 /* Do auto-compile on/off now, because the form itself might need this
617 else if (! strcmp (argv
[i
], "--auto-compile"))
618 scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
621 else if (! strcmp (argv
[i
], "--no-auto-compile"))
622 scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
625 else if (! strcmp (argv
[i
], "-q")) /* don't load user init */
626 inhibit_user_init
= 1;
628 else if (! strncmp (argv
[i
], "--use-srfi=", 11)) /* load SRFIs */
630 SCM srfis
= SCM_EOL
; /* List of requested SRFIs. */
631 char * p
= argv
[i
] + 11;
637 num
= strtol (p
, &end
, 10);
640 srfis
= scm_cons (scm_from_long (num
), srfis
);
646 scm_shell_usage (1, "invalid SRFI specification");
652 scm_shell_usage (1, "invalid SRFI specification");
654 if (scm_ilength (srfis
) <= 0)
655 scm_shell_usage (1, "invalid SRFI specification");
656 srfis
= scm_reverse_x (srfis
, SCM_UNDEFINED
);
657 tail
= scm_cons (scm_list_2 (sym_use_srfis
,
658 scm_list_2 (scm_sym_quote
, srfis
)),
662 else if (! strncmp (argv
[i
], "--listen", 8) /* start a repl server */
663 && (argv
[i
][8] == '\0' || argv
[i
][8] == '='))
665 const char default_template
[] =
666 "(@@ (system repl server) (spawn-server))";
667 const char port_template
[] =
668 "(@@ (system repl server)"
669 " (spawn-server (make-tcp-server-socket #:port ~a)))";
670 const char path_template
[] =
671 "(@@ (system repl server)"
672 " (spawn-server (make-unix-domain-server-socket #:path ~s)))";
674 SCM form_str
= SCM_BOOL_F
;
675 char * p
= argv
[i
] + 8;
680 if (*p
> '0' && *p
<= '9')
683 SCM port
= scm_string_to_number (scm_from_locale_string (p
),
686 if (scm_is_false (port
))
687 scm_shell_usage (1, "invalid port for --listen");
690 scm_simple_format (SCM_BOOL_F
,
691 scm_from_locale_string (port_template
),
696 /* --listen=/PATH/TO/SOCKET */
697 SCM path
= scm_from_locale_string (p
);
700 scm_simple_format (SCM_BOOL_F
,
701 scm_from_locale_string (path_template
),
706 /* unknown --listen arg */
707 scm_shell_usage (1, "unknown argument to --listen");
711 form_str
= scm_from_locale_string (default_template
);
713 tail
= scm_cons (scm_read (scm_open_input_string (form_str
)), tail
);
716 else if (! strcmp (argv
[i
], "-h")
717 || ! strcmp (argv
[i
], "--help"))
719 scm_shell_usage (0, 0);
723 else if (! strcmp (argv
[i
], "-v")
724 || ! strcmp (argv
[i
], "--version"))
726 /* Print version number. */
727 version_etc (stdout
, scm_usage_name
, PACKAGE_NAME
, PACKAGE_VERSION
,
728 /* XXX: Use gettext for the string below. */
729 "the Guile developers", NULL
);
735 fprintf (stderr
, "%s: Unrecognized switch `%s'\n",
736 scm_usage_name
, argv
[i
]);
737 scm_shell_usage (1, 0);
741 /* Check to make sure the -ds got a -s. */
742 if (!scm_is_null (do_script
))
743 scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
745 /* Make any remaining arguments available to the
746 script/command/whatever. */
747 scm_set_program_arguments (argc
? argc
- i
: 0, argv
+ i
, argv0
);
749 /* Handle the `-e' switch, if it was specified. */
750 if (!scm_is_null (entry_point
))
751 tail
= scm_cons (scm_cons2 (entry_point
,
752 scm_cons (sym_command_line
, SCM_EOL
),
756 /* If we didn't end with a -c or a -s, start the repl. */
759 tail
= scm_cons (scm_list_1 (scm_list_3
761 scm_list_2 (sym_ice_9
, sym_top_repl
),
767 /* After doing all the other actions prescribed by the command line,
769 tail
= scm_cons (scm_cons (sym_quit
, SCM_EOL
),
773 /* After the following line, actions will be added to the front. */
774 tail
= scm_reverse_x (tail
, SCM_UNDEFINED
);
776 /* add the user-specified load path here, so it won't be in effect
777 during the loading of the user's customization file. */
778 if(!scm_is_null(user_load_path
))
780 tail
= scm_append_x( scm_cons2(user_load_path
, tail
, SCM_EOL
) );
783 if (!scm_is_null (user_extensions
))
784 tail
= scm_append_x (scm_cons2 (user_extensions
, tail
, SCM_EOL
));
786 /* If we didn't end with a -c or a -s and didn't supply a -q, load
787 the user's customization file. */
788 if (interactive
&& !inhibit_user_init
)
790 tail
= scm_cons (scm_cons (sym_load_user_init
, SCM_EOL
), tail
);
793 /* If debugging was requested, or we are interactive and debugging
794 was not explicitly turned off, use the debug engine. */
795 if (turn_on_debugging
|| (interactive
&& !dont_turn_on_debugging
))
797 scm_c_set_default_vm_engine_x (SCM_VM_DEBUG_ENGINE
);
798 scm_c_set_vm_engine_x (scm_the_vm (), SCM_VM_DEBUG_ENGINE
);
802 SCM val
= scm_cons (sym_begin
, tail
);
804 /* Wrap the expression in a prompt. */
805 val
= scm_list_2 (scm_list_3 (scm_sym_at
,
806 scm_list_2 (scm_from_latin1_symbol ("ice-9"),
807 scm_from_latin1_symbol ("control")),
808 scm_from_latin1_symbol ("%")),
812 scm_write (val
, SCM_UNDEFINED
);
813 scm_newline (SCM_UNDEFINED
);
822 scm_shell (int argc
, char **argv
)
824 /* If present, add SCSH-style meta-arguments from the top of the
825 script file to the argument vector. See the SCSH manual: "The
826 meta argument" for more details. */
828 char **new_argv
= scm_get_meta_args (argc
, argv
);
833 argc
= scm_count_argv (new_argv
);
837 exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc
, argv
),
838 scm_current_module ())));
845 #include "libguile/script.x"