-/* 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 <config.h>
-#endif
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <errno.h>
-#include <ctype.h>
-
-#include <version-etc.h>
-
-#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 <string.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h> /* for X_OK define */
-#endif
-
-#ifdef HAVE_IO_H
-#include <io.h>
-#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 <config.h>
+#endif
+
+#include <localcharset.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <errno.h>
+#include <ctype.h>
+#include <uniconv.h>
+
+#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 <string.h>
+#endif
+
+#include <unistd.h> /* for X_OK define */
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#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
+ <http://lists.gnu.org/archive/html/guile-devel/2011-11/msg00040.html>
+ 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:
+*/
HCoop / bpt / guile.git / blobdiff