mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity
guile/libguile/script.c
Andy Wingo a531e76a74 add --listen command line argument. 
* libguile/script.c (scm_shell_usage, scm_compile_shell_switches): Add a
  --listen argument to spawn a REPL server, possibly specifying the port
  or path to listen on. The goal is for this to be the default way to
  allow debugging via Emacs or simply using netcat.
2010-10-10 12:56:53 +02:00

832 lines
22 KiB
C
Raw Blame History

/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 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"
" -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_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 */
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], "-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 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_locale_symbol ("ice-9"),
scm_from_locale_symbol ("control")),
scm_from_locale_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:
*/
View git blame Copy permalink