X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/4a655e50a3890da9cd453a0b2c83dacc2cfcc34e..5dae693cb5f8f082b3188f3dc955d1f86fe6a50a:/libguile/script.c diff --git a/libguile/script.c b/libguile/script.c dissimilarity index 64% index b4dcd7bf4..63fbb0f3f 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,852 +1,469 @@ -/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - -/* "script.c" argv tricks for `#!' scripts. - Authors: Aubrey Jaffer and Jim Blandy */ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include -#include -#include - -#include - -#include "libguile/_scm.h" -#include "libguile/eval.h" -#include "libguile/feature.h" -#include "libguile/load.h" -#include "libguile/private-gc.h" /* scm_getenv_int */ -#include "libguile/read.h" -#include "libguile/script.h" -#include "libguile/strings.h" -#include "libguile/strports.h" -#include "libguile/validate.h" -#include "libguile/version.h" -#include "libguile/vm.h" - -#ifdef HAVE_STRING_H -#include -#endif - -#ifdef HAVE_UNISTD_H -#include /* for X_OK define */ -#endif - -#ifdef HAVE_IO_H -#include -#endif - -/* Concatentate str2 onto str1 at position n and return concatenated - string if file exists; 0 otherwise. */ - -static char * -scm_cat_path (char *str1, const char *str2, long n) -{ - if (!n) - n = strlen (str2); - if (str1) - { - size_t len = strlen (str1); - str1 = (char *) realloc (str1, (size_t) (len + n + 1)); - if (!str1) - return 0L; - strncat (str1 + len, str2, n); - return str1; - } - str1 = (char *) scm_malloc ((size_t) (n + 1)); - if (!str1) - return 0L; - str1[0] = 0; - strncat (str1, str2, n); - return str1; -} - -#if 0 -static char * -scm_try_path (char *path) -{ - FILE *f; - /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */ - if (!path) - return 0L; - SCM_SYSCALL (f = fopen (path, "r"); - ); - if (f) - { - fclose (f); - return path; - } - free (path); - return 0L; -} - -static char * -scm_sep_init_try (char *path, const char *sep, const char *initname) -{ - if (path) - path = scm_cat_path (path, sep, 0L); - if (path) - path = scm_cat_path (path, initname, 0L); - return scm_try_path (path); -} -#endif - -#ifndef LINE_INCREMENTORS -#define LINE_INCREMENTORS '\n' -#ifdef MSDOS -#define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26 -#else -#define WHITE_SPACES ' ':case '\t':case '\r':case '\f' -#endif /* def MSDOS */ -#endif /* ndef LINE_INCREMENTORS */ - -#ifndef MAXPATHLEN -#define MAXPATHLEN 80 -#endif /* ndef MAXPATHLEN */ -#ifndef X_OK -#define X_OK 1 -#endif /* ndef X_OK */ - -char * -scm_find_executable (const char *name) -{ - char tbuf[MAXPATHLEN]; - int i = 0, c; - FILE *f; - - /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */ - if (access (name, X_OK)) - return 0L; - f = fopen (name, "r"); - if (!f) - return 0L; - if ((fgetc (f) == '#') && (fgetc (f) == '!')) - { - while (1) - switch (c = fgetc (f)) - { - case /*WHITE_SPACES */ ' ': - case '\t': - case '\r': - case '\f': - case EOF: - tbuf[i] = 0; - fclose (f); - return scm_cat_path (0L, tbuf, 0L); - default: - tbuf[i++] = c; - break; - } - } - fclose (f); - return scm_cat_path (0L, name, 0L); -} - - -/* Read a \nnn-style escape. We've just read the backslash. */ -static int -script_get_octal (FILE *f) -#define FUNC_NAME "script_get_octal" -{ - int i; - int value = 0; - - for (i = 0; i < 3; i++) - { - int c = getc (f); - if ('0' <= c && c <= '7') - value = (value * 8) + (c - '0'); - else - SCM_MISC_ERROR ("malformed script: bad octal backslash escape", - SCM_EOL); - } - return value; -} -#undef FUNC_NAME - - -static int -script_get_backslash (FILE *f) -#define FUNC_NAME "script_get_backslash" -{ - int c = getc (f); - - switch (c) - { - case 'a': return '\a'; - case 'b': return '\b'; - case 'f': return '\f'; - case 'n': return '\n'; - case 'r': return '\r'; - case 't': return '\t'; - case 'v': return '\v'; - - case '\\': - case ' ': - case '\t': - case '\n': - return c; - - case '0': case '1': case '2': case '3': - case '4': case '5': case '6': case '7': - ungetc (c, f); - return script_get_octal (f); - - case EOF: - SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); - return 0; /* not reached? */ - - default: - SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); - return 0; /* not reached? */ - } -} -#undef FUNC_NAME - - -static char * -script_read_arg (FILE *f) -#define FUNC_NAME "script_read_arg" -{ - size_t size = 7; - char *buf = scm_malloc (size + 1); - size_t len = 0; - - if (! buf) - return 0; - - for (;;) - { - int c = getc (f); - switch (c) - { - case '\\': - c = script_get_backslash (f); - /* The above produces a new character to add to the argument. - Fall through. */ - default: - if (len >= size) - { - size = (size + 1) * 2; - buf = realloc (buf, size); - if (! buf) - return 0; - } - buf[len++] = c; - break; - - case '\n': - /* This may terminate an arg now, but it will terminate the - entire list next time through. */ - ungetc ('\n', f); - case EOF: - if (len == 0) - { - free (buf); - return 0; - } - /* Otherwise, those characters terminate the argument; fall - through. */ - case ' ': - buf[len] = '\0'; - return buf; - - case '\t': - free (buf); - SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); - return 0; /* not reached? */ - } - } -} -#undef FUNC_NAME - - -static int -script_meta_arg_P (char *arg) -{ - if ('\\' != arg[0]) - return 0L; -#ifdef MSDOS - return !arg[1]; -#else - switch (arg[1]) - { - case 0: - case '%': - case WHITE_SPACES: - return !0; - default: - return 0L; - } -#endif -} - -char ** -scm_get_meta_args (int argc, char **argv) -{ - int nargc = argc, argi = 1, nargi = 1; - char *narg, **nargv; - if (!(argc > 2 && script_meta_arg_P (argv[1]))) - return 0L; - if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *)))) - return 0L; - nargv[0] = argv[0]; - while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi]))) - { - FILE *f = fopen (argv[++argi], "r"); - if (f) - { - nargc--; /* to compensate for replacement of '\\' */ - while (1) - switch (getc (f)) - { - case EOF: - return 0L; - default: - continue; - case '\n': - goto found_args; - } - found_args: - while ((narg = script_read_arg (f))) - if (!(nargv = (char **) realloc (nargv, - (1 + ++nargc) * sizeof (char *)))) - return 0L; - else - nargv[nargi++] = narg; - fclose (f); - nargv[nargi++] = argv[argi++]; - } - } - while (argi <= argc) - nargv[nargi++] = argv[argi++]; - return nargv; -} - -int -scm_count_argv (char **argv) -{ - int argc = 0; - while (argv[argc]) - argc++; - return argc; -} - - -/* For use in error messages. */ -char *scm_usage_name = 0; - -void -scm_shell_usage (int fatal, char *message) -{ - FILE *fp = (fatal ? stderr : stdout); - - if (message) - fprintf (fp, "%s\n", message); - - fprintf (fp, - "Usage: %s [OPTION]... [FILE]...\n" - "Evaluate Scheme code, interactively or from a script.\n" - "\n" - " [-s] FILE load Scheme source code from FILE, and exit\n" - " -c EXPR evalute Scheme expression EXPR, and exit\n" - " -- stop scanning arguments; run interactively\n\n" - "The above switches stop argument processing, and pass all\n" - "remaining arguments as the value of (command-line).\n" - "If FILE begins with `-' the -s switch is mandatory.\n" - "\n" - " -L DIRECTORY add DIRECTORY to the front of the module load path\n" - " -x EXTENSION add EXTENSION to the front of the load extensions\n" - " -l FILE load Scheme source code from FILE\n" - " -e FUNCTION after reading script, apply FUNCTION to\n" - " command line arguments\n" - " -ds do -s script at this point\n" - " --debug start with debugging evaluator and backtraces\n" - " --no-debug start with normal evaluator\n" - " Default is to enable debugging for interactive\n" - " use, but not for `-s' and `-c'.\n" - " --autocompile compile source files automatically\n" - " --no-autocompile disable automatic source file compilation\n" - " Default is to enable autocompilation of source\n" - " files.\n" - " --listen[=P] Listen on a local port or a path for REPL clients.\n" - " If P is not given, the default is local port 37146.\n" - " -q inhibit loading of user init file\n" - " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n" - " which is a list of numbers like \"2,13,14\"\n" - " -h, --help display this help and exit\n" - " -v, --version display version information and exit\n" - " \\ read arguments from following script lines\n", - scm_usage_name); - - emit_bug_reporting_address (); - - if (fatal) - exit (fatal); -} - - -/* Some symbols used by the command-line compiler. */ -SCM_SYMBOL (sym_load, "load"); -SCM_SYMBOL (sym_eval_string, "eval-string"); -SCM_SYMBOL (sym_command_line, "command-line"); -SCM_SYMBOL (sym_begin, "begin"); -SCM_SYMBOL (sym_load_user_init, "load-user-init"); -SCM_SYMBOL (sym_ice_9, "ice-9"); -SCM_SYMBOL (sym_top_repl, "top-repl"); -SCM_SYMBOL (sym_quit, "quit"); -SCM_SYMBOL (sym_use_srfis, "use-srfis"); -SCM_SYMBOL (sym_load_path, "%load-path"); -SCM_SYMBOL (sym_load_extensions, "%load-extensions"); -SCM_SYMBOL (sym_set_x, "set!"); -SCM_SYMBOL (sym_sys_load_should_autocompile, "%load-should-autocompile"); -SCM_SYMBOL (sym_cons, "cons"); -SCM_SYMBOL (sym_at, "@"); -SCM_SYMBOL (sym_atat, "@@"); -SCM_SYMBOL (sym_main, "main"); - -/* Given an array of command-line switches, return a Scheme expression - to carry out the actions specified by the switches. - - If you told me this should have been written in Scheme, I'd - probably agree. I'd say I didn't feel comfortable doing that in - the present system. You'd say, well, fix the system so you are - comfortable doing that. I'd agree again. *shrug* - */ - -static char guile[] = "guile"; - -static int -all_symbols (SCM list) -{ - while (scm_is_pair (list)) - { - if (!scm_is_symbol (SCM_CAR (list))) - return 0; - list = SCM_CDR (list); - } - return 1; -} - -SCM -scm_compile_shell_switches (int argc, char **argv) -{ - SCM tail = SCM_EOL; /* We accumulate the list backwards, - and then reverse! it before we - return it. */ - SCM do_script = SCM_EOL; /* The element of the list containing - the "load" command, in case we get - the "-ds" switch. */ - SCM entry_point = SCM_EOL; /* for -e switch */ - SCM user_load_path = SCM_EOL; /* for -L switch */ - SCM user_extensions = SCM_EOL;/* for -x switch */ - int interactive = 1; /* Should we go interactive when done? */ - int inhibit_user_init = 0; /* Don't load user init file */ - int turn_on_debugging = 0; - int dont_turn_on_debugging = 0; - - int i; - char *argv0 = guile; - - if (argc > 0) - { - argv0 = argv[0]; - scm_usage_name = strrchr (argv[0], '/'); - if (! scm_usage_name) - scm_usage_name = argv[0]; - else - scm_usage_name++; - } - if (! scm_usage_name) - scm_usage_name = guile; - - for (i = 1; i < argc; i++) - { - if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */ - { - if ((argv[i][0] == '-') && (++i >= argc)) - scm_shell_usage (1, "missing argument to `-s' switch"); - - /* If we specified the -ds option, do_script points to the - cdr of an expression like (load #f); we replace the car - (i.e., the #f) with the script name. */ - if (!scm_is_null (do_script)) - { - SCM_SETCAR (do_script, scm_from_locale_string (argv[i])); - do_script = SCM_EOL; - } - else - /* Construct an application of LOAD to the script name. */ - tail = scm_cons (scm_cons2 (sym_load, - scm_from_locale_string (argv[i]), - SCM_EOL), - tail); - argv0 = argv[i]; - i++; - interactive = 0; - break; - } - - else if (! strcmp (argv[i], "-c")) /* evaluate expr */ - { - if (++i >= argc) - scm_shell_usage (1, "missing argument to `-c' switch"); - tail = scm_cons (scm_cons2 (sym_eval_string, - scm_from_locale_string (argv[i]), - SCM_EOL), - tail); - i++; - interactive = 0; - break; - } - - else if (! strcmp (argv[i], "--")) /* end args; go interactive */ - { - i++; - break; - } - - else if (! strcmp (argv[i], "-l")) /* load a file */ - { - if (++i < argc) - tail = scm_cons (scm_cons2 (sym_load, - scm_from_locale_string (argv[i]), - SCM_EOL), - tail); - else - scm_shell_usage (1, "missing argument to `-l' switch"); - } - - else if (! strcmp (argv[i], "-L")) /* add to %load-path */ - { - if (++i < argc) - user_load_path = - scm_cons (scm_list_3 (sym_set_x, - sym_load_path, - scm_list_3 (sym_cons, - scm_from_locale_string (argv[i]), - sym_load_path)), - user_load_path); - else - scm_shell_usage (1, "missing argument to `-L' switch"); - } - - else if (! strcmp (argv[i], "-x")) /* add to %load-extensions */ - { - if (++i < argc) - user_extensions = - scm_cons (scm_list_3 (sym_set_x, - sym_load_extensions, - scm_list_3 (sym_cons, - scm_from_locale_string (argv[i]), - sym_load_extensions)), - user_extensions); - else - scm_shell_usage (1, "missing argument to `-x' switch"); - } - - else if (! strcmp (argv[i], "-e")) /* entry point */ - { - if (++i < argc) - { - SCM port - = scm_open_input_string (scm_from_locale_string (argv[i])); - SCM arg1 = scm_read (port); - SCM arg2 = scm_read (port); - - /* Recognize syntax of certain versions of Guile 1.4 and - transform to (@ MODULE-NAME FUNC). - */ - if (scm_is_false (scm_eof_object_p (arg2))) - entry_point = scm_list_3 (sym_at, arg1, arg2); - else if (scm_is_pair (arg1) - && !(scm_is_eq (SCM_CAR (arg1), sym_at) - || scm_is_eq (SCM_CAR (arg1), sym_atat)) - && all_symbols (arg1)) - entry_point = scm_list_3 (sym_at, arg1, sym_main); - else - entry_point = arg1; - } - else - scm_shell_usage (1, "missing argument to `-e' switch"); - } - - else if (! strcmp (argv[i], "-ds")) /* do script here */ - { - /* We put a dummy "load" expression, and let the -s put the - filename in. */ - if (!scm_is_null (do_script)) - scm_shell_usage (1, "the -ds switch may only be specified once"); - do_script = scm_cons (SCM_BOOL_F, SCM_EOL); - tail = scm_cons (scm_cons (sym_load, do_script), - tail); - } - - else if (! strcmp (argv[i], "--debug")) - { - turn_on_debugging = 1; - dont_turn_on_debugging = 0; - } - - else if (! strcmp (argv[i], "--no-debug")) - { - dont_turn_on_debugging = 1; - turn_on_debugging = 0; - } - - /* Do autocompile on/off now, because the form itself might need this - decision. */ - else if (! strcmp (argv[i], "--autocompile")) - scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"), - SCM_BOOL_T); - - else if (! strcmp (argv[i], "--no-autocompile")) - scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"), - SCM_BOOL_F); - - else if (! strcmp (argv[i], "-q")) /* don't load user init */ - inhibit_user_init = 1; - - else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */ - { - SCM srfis = SCM_EOL; /* List of requested SRFIs. */ - char * p = argv[i] + 11; - while (*p) - { - long num; - char * end; - - num = strtol (p, &end, 10); - if (end - p > 0) - { - srfis = scm_cons (scm_from_long (num), srfis); - if (*end) - { - if (*end == ',') - p = end + 1; - else - scm_shell_usage (1, "invalid SRFI specification"); - } - else - break; - } - else - scm_shell_usage (1, "invalid SRFI specification"); - } - if (scm_ilength (srfis) <= 0) - scm_shell_usage (1, "invalid SRFI specification"); - srfis = scm_reverse_x (srfis, SCM_UNDEFINED); - tail = scm_cons (scm_list_2 (sym_use_srfis, - scm_list_2 (scm_sym_quote, srfis)), - tail); - } - - else if (! strncmp (argv[i], "--listen", 8) /* start a repl server */ - && (argv[i][8] == '\0' || argv[i][8] == '=')) - { - const char default_template[] = - "(@@ (system repl server) (spawn-server))"; - const char port_template[] = - "(@@ (system repl server)" - " (spawn-server (make-tcp-server-socket #:port ~a)))"; - const char path_template[] = - "(@@ (system repl server)" - " (spawn-server (make-unix-domain-server-socket #:path ~s)))"; - - SCM form_str = SCM_BOOL_F; - char * p = argv[i] + 8; - - if (*p == '=') - { - p++; - if (*p > '0' && *p <= '9') - { - /* --listen=PORT */ - SCM port = scm_string_to_number (scm_from_locale_string (p), - SCM_UNDEFINED); - - if (scm_is_false (port)) - scm_shell_usage (1, "invalid port for --listen"); - - form_str = - scm_simple_format (SCM_BOOL_F, - scm_from_locale_string (port_template), - scm_list_1 (port)); - } - else if (*p == '/') - { - /* --listen=/PATH/TO/SOCKET */ - SCM path = scm_from_locale_string (p); - - form_str = - scm_simple_format (SCM_BOOL_F, - scm_from_locale_string (path_template), - scm_list_1 (path)); - } - else - { - /* unknown --listen arg */ - scm_shell_usage (1, "unknown argument to --listen"); - } - } - else - form_str = scm_from_locale_string (default_template); - - tail = scm_cons (scm_read (scm_open_input_string (form_str)), tail); - } - - else if (! strcmp (argv[i], "-h") - || ! strcmp (argv[i], "--help")) - { - scm_shell_usage (0, 0); - exit (EXIT_SUCCESS); - } - - else if (! strcmp (argv[i], "-v") - || ! strcmp (argv[i], "--version")) - { - /* Print version number. */ - version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION, - /* XXX: Use gettext for the string below. */ - "the Guile developers", NULL); - exit (EXIT_SUCCESS); - } - - else - { - fprintf (stderr, "%s: Unrecognized switch `%s'\n", - scm_usage_name, argv[i]); - scm_shell_usage (1, 0); - } - } - - /* Check to make sure the -ds got a -s. */ - if (!scm_is_null (do_script)) - scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well"); - - /* Make any remaining arguments available to the - script/command/whatever. */ - scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0); - - /* Handle the `-e' switch, if it was specified. */ - if (!scm_is_null (entry_point)) - tail = scm_cons (scm_cons2 (entry_point, - scm_cons (sym_command_line, SCM_EOL), - SCM_EOL), - tail); - - /* If we didn't end with a -c or a -s, start the repl. */ - if (interactive) - { - tail = scm_cons (scm_list_1 (scm_list_3 - (sym_at, - scm_list_2 (sym_ice_9, sym_top_repl), - sym_top_repl)), - tail); - } - else - { - /* After doing all the other actions prescribed by the command line, - quit. */ - tail = scm_cons (scm_cons (sym_quit, SCM_EOL), - tail); - } - - /* After the following line, actions will be added to the front. */ - tail = scm_reverse_x (tail, SCM_UNDEFINED); - - /* add the user-specified load path here, so it won't be in effect - during the loading of the user's customization file. */ - if(!scm_is_null(user_load_path)) - { - tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) ); - } - - if (!scm_is_null (user_extensions)) - tail = scm_append_x (scm_cons2 (user_extensions, tail, SCM_EOL)); - - /* If we didn't end with a -c or a -s and didn't supply a -q, load - the user's customization file. */ - if (interactive && !inhibit_user_init) - { - tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail); - } - - /* If debugging was requested, or we are interactive and debugging - was not explicitly turned off, use the debug engine. */ - if (turn_on_debugging || (interactive && !dont_turn_on_debugging)) - { - scm_c_set_default_vm_engine_x (SCM_VM_DEBUG_ENGINE); - scm_c_set_vm_engine_x (scm_the_vm (), SCM_VM_DEBUG_ENGINE); - } - - { - SCM val = scm_cons (sym_begin, tail); - - /* Wrap the expression in a prompt. */ - val = scm_list_2 (scm_list_3 (scm_sym_at, - scm_list_2 (scm_from_latin1_symbol ("ice-9"), - scm_from_latin1_symbol ("control")), - scm_from_latin1_symbol ("%")), - val); - -#if 0 - scm_write (val, SCM_UNDEFINED); - scm_newline (SCM_UNDEFINED); -#endif - - return val; - } -} - - -void -scm_shell (int argc, char **argv) -{ - /* If present, add SCSH-style meta-arguments from the top of the - script file to the argument vector. See the SCSH manual: "The - meta argument" for more details. */ - { - char **new_argv = scm_get_meta_args (argc, argv); - - if (new_argv) - { - argv = new_argv; - argc = scm_count_argv (new_argv); - } - } - - exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), - scm_current_module ()))); -} - - -void -scm_init_script () -{ -#include "libguile/script.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +/* "script.c" argv tricks for `#!' scripts. + Authors: Aubrey Jaffer and Jim Blandy */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/feature.h" +#include "libguile/load.h" +#include "libguile/read.h" +#include "libguile/script.h" +#include "libguile/strings.h" +#include "libguile/strports.h" +#include "libguile/validate.h" +#include "libguile/version.h" +#include "libguile/vm.h" + +#ifdef HAVE_STRING_H +#include +#endif + +#include /* for X_OK define */ + +#ifdef HAVE_IO_H +#include +#endif + +/* Concatentate str2 onto str1 at position n and return concatenated + string if file exists; 0 otherwise. */ + +static char * +scm_cat_path (char *str1, const char *str2, long n) +{ + if (!n) + n = strlen (str2); + if (str1) + { + size_t len = strlen (str1); + str1 = (char *) realloc (str1, (size_t) (len + n + 1)); + if (!str1) + return 0L; + strncat (str1 + len, str2, n); + return str1; + } + str1 = (char *) scm_malloc ((size_t) (n + 1)); + if (!str1) + return 0L; + str1[0] = 0; + strncat (str1, str2, n); + return str1; +} + +#if 0 +static char * +scm_try_path (char *path) +{ + FILE *f; + /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */ + if (!path) + return 0L; + SCM_SYSCALL (f = fopen (path, "r"); + ); + if (f) + { + fclose (f); + return path; + } + free (path); + return 0L; +} + +static char * +scm_sep_init_try (char *path, const char *sep, const char *initname) +{ + if (path) + path = scm_cat_path (path, sep, 0L); + if (path) + path = scm_cat_path (path, initname, 0L); + return scm_try_path (path); +} +#endif + +#ifndef LINE_INCREMENTORS +#define LINE_INCREMENTORS '\n' +#ifdef MSDOS +#define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26 +#else +#define WHITE_SPACES ' ':case '\t':case '\r':case '\f' +#endif /* def MSDOS */ +#endif /* ndef LINE_INCREMENTORS */ + +#ifndef MAXPATHLEN +#define MAXPATHLEN 80 +#endif /* ndef MAXPATHLEN */ +#ifndef X_OK +#define X_OK 1 +#endif /* ndef X_OK */ + +char * +scm_find_executable (const char *name) +{ + char tbuf[MAXPATHLEN]; + int i = 0, c; + FILE *f; + + /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */ + if (access (name, X_OK)) + return 0L; + f = fopen (name, "r"); + if (!f) + return 0L; + if ((fgetc (f) == '#') && (fgetc (f) == '!')) + { + while (1) + switch (c = fgetc (f)) + { + case /*WHITE_SPACES */ ' ': + case '\t': + case '\r': + case '\f': + case EOF: + tbuf[i] = 0; + fclose (f); + return scm_cat_path (0L, tbuf, 0L); + default: + tbuf[i++] = c; + break; + } + } + fclose (f); + return scm_cat_path (0L, name, 0L); +} + + +/* Read a \nnn-style escape. We've just read the backslash. */ +static int +script_get_octal (FILE *f) +#define FUNC_NAME "script_get_octal" +{ + int i; + int value = 0; + + for (i = 0; i < 3; i++) + { + int c = getc (f); + if ('0' <= c && c <= '7') + value = (value * 8) + (c - '0'); + else + SCM_MISC_ERROR ("malformed script: bad octal backslash escape", + SCM_EOL); + } + return value; +} +#undef FUNC_NAME + + +static int +script_get_backslash (FILE *f) +#define FUNC_NAME "script_get_backslash" +{ + int c = getc (f); + + switch (c) + { + case 'a': return '\a'; + case 'b': return '\b'; + case 'f': return '\f'; + case 'n': return '\n'; + case 'r': return '\r'; + case 't': return '\t'; + case 'v': return '\v'; + + case '\\': + case ' ': + case '\t': + case '\n': + return c; + + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + ungetc (c, f); + return script_get_octal (f); + + case EOF: + SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); + return 0; /* not reached? */ + + default: + SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); + return 0; /* not reached? */ + } +} +#undef FUNC_NAME + +/* + * Like `realloc', but free memory on failure; + * unlike `scm_realloc', return NULL, not aborts. +*/ +static void* +realloc0 (void *ptr, size_t size) +{ + void *new_ptr = realloc (ptr, size); + if (!new_ptr) + { + free (ptr); + } + return new_ptr; +} + + +static char * +script_read_arg (FILE *f) +#define FUNC_NAME "script_read_arg" +{ + size_t size = 7; + char *buf = scm_malloc (size + 1); + size_t len = 0; + + if (! buf) + return 0; + + for (;;) + { + int c = getc (f); + switch (c) + { + case '\\': + c = script_get_backslash (f); + /* The above produces a new character to add to the argument. + Fall through. */ + default: + if (len >= size) + { + size = (size + 1) * 2; + buf = realloc0 (buf, size); + if (! buf) + return 0; + } + buf[len++] = c; + break; + + case '\n': + /* This may terminate an arg now, but it will terminate the + entire list next time through. */ + ungetc ('\n', f); + case EOF: + if (len == 0) + { + free (buf); + return 0; + } + /* Otherwise, those characters terminate the argument; fall + through. */ + case ' ': + buf[len] = '\0'; + return buf; + + case '\t': + free (buf); + SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); + return 0; /* not reached? */ + } + } +} +#undef FUNC_NAME + + +static int +script_meta_arg_P (char *arg) +{ + if ('\\' != arg[0]) + return 0L; +#ifdef MSDOS + return !arg[1]; +#else + switch (arg[1]) + { + case 0: + case '%': + case WHITE_SPACES: + return !0; + default: + return 0L; + } +#endif +} + +char ** +scm_get_meta_args (int argc, char **argv) +{ + int nargc = argc, argi = 1, nargi = 1; + char *narg, **nargv; + if (!(argc > 2 && script_meta_arg_P (argv[1]))) + return 0L; + if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *)))) + return 0L; + nargv[0] = argv[0]; + while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi]))) + { + FILE *f = fopen (argv[++argi], "r"); + if (f) + { + nargc--; /* to compensate for replacement of '\\' */ + while (1) + switch (getc (f)) + { + case EOF: + free (nargv); + return 0L; + default: + continue; + case '\n': + goto found_args; + } + found_args: + /* FIXME: we leak the result of calling script_read_arg. */ + while ((narg = script_read_arg (f))) + if (!(nargv = (char **) realloc0 (nargv, + (1 + ++nargc) * sizeof (char *)))) + return 0L; + else + nargv[nargi++] = narg; + fclose (f); + nargv[nargi++] = argv[argi++]; + } + } + while (argi <= argc) + nargv[nargi++] = argv[argi++]; + return nargv; +} + +int +scm_count_argv (char **argv) +{ + int argc = 0; + while (argv[argc]) + argc++; + return argc; +} + + +/* For use in error messages. */ +char *scm_usage_name = 0; + +void +scm_shell_usage (int fatal, char *message) +{ + scm_call_3 (scm_c_private_ref ("ice-9 command-line", + "shell-usage"), + (scm_usage_name + ? scm_from_locale_string (scm_usage_name) + : scm_from_latin1_string ("guile")), + scm_from_bool (fatal), + (message + ? scm_from_locale_string (message) + : SCM_BOOL_F)); +} + +/* Return a list of strings from ARGV, which contains ARGC strings + assumed to be encoded in the current locale. Use + `environ_locale_charset' instead of relying on + `scm_from_locale_string' because the user hasn't had a change to call + (setlocale LC_ALL "") yet. + + XXX: This hack is for 2.0 and will be removed in the next stable + series where the `setlocale' call will be implicit. See + + for details. */ +static SCM +locale_arguments_to_string_list (int argc, char **const argv) +{ + int i; + SCM lst; + const char *encoding; + + encoding = environ_locale_charset (); + for (i = argc - 1, lst = SCM_EOL; + i >= 0; + i--) + lst = scm_cons (scm_from_stringn (argv[i], (size_t) -1, encoding, + SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE), + lst); + + return lst; +} + +/* Set the value returned by `program-arguments', given ARGC and ARGV. */ +void +scm_i_set_boot_program_arguments (int argc, char *argv[]) +{ + scm_fluid_set_x (scm_program_arguments_fluid, + locale_arguments_to_string_list (argc, argv)); +} + +/* Given an array of command-line switches, return a Scheme expression + to carry out the actions specified by the switches. + */ + +SCM +scm_compile_shell_switches (int argc, char **argv) +{ + return scm_call_2 (scm_c_public_ref ("ice-9 command-line", + "compile-shell-switches"), + locale_arguments_to_string_list (argc, argv), + (scm_usage_name + ? scm_from_locale_string (scm_usage_name) + : scm_from_latin1_string ("guile"))); +} + + +void +scm_shell (int argc, char **argv) +{ + /* If present, add SCSH-style meta-arguments from the top of the + script file to the argument vector. See the SCSH manual: "The + meta argument" for more details. */ + { + char **new_argv = scm_get_meta_args (argc, argv); + + if (new_argv) + { + argv = new_argv; + argc = scm_count_argv (new_argv); + } + } + + exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), + scm_current_module ()))); +} + + +void +scm_init_script () +{ +#include "libguile/script.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/