mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
573 lines
13 KiB
C
573 lines
13 KiB
C
/* readline.c --- line editing support for Guile */
|
||
|
||
/* Copyright 1997,1999,2000-2003,2006-2010,2013,2018
|
||
Free Software Foundation, Inc.
|
||
|
||
This file is part of Guile-Readline.
|
||
|
||
Guile-Readline is free software: you can redistribute it and/or
|
||
modify it under the terms of the GNU General Public License as
|
||
published by the Free Software Foundation, either version 3 of the
|
||
License, or (at your option) any later version.
|
||
|
||
Guile-Readline 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
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with Guile-Readline. If not, see
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#ifdef HAVE_RL_GETC_FUNCTION
|
||
#include <stdio.h>
|
||
#include <string.h>
|
||
#include <unistd.h>
|
||
#include <sys/time.h>
|
||
#include <sys/select.h>
|
||
#include <signal.h>
|
||
|
||
#include <readline/readline.h>
|
||
#include <readline/history.h>
|
||
|
||
#include <libguile.h>
|
||
|
||
#include "readline.h"
|
||
|
||
scm_t_option scm_readline_opts[] = {
|
||
{ SCM_OPTION_BOOLEAN, "history-file", 1,
|
||
"Use history file." },
|
||
{ SCM_OPTION_INTEGER, "history-length", 200,
|
||
"History length." },
|
||
{ SCM_OPTION_INTEGER, "bounce-parens", 500,
|
||
"Time (ms) to show matching opening parenthesis (0 = off)."},
|
||
{ SCM_OPTION_BOOLEAN, "bracketed-paste", 1,
|
||
"Disable interpretation of control characters in pastes." },
|
||
{ 0 }
|
||
};
|
||
|
||
extern void stifle_history (int max);
|
||
|
||
SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
|
||
(SCM setting),
|
||
"")
|
||
#define FUNC_NAME s_scm_readline_options
|
||
{
|
||
SCM ans = scm_options (setting,
|
||
scm_readline_opts,
|
||
FUNC_NAME);
|
||
if (!SCM_UNBNDP (setting)) {
|
||
stifle_history (SCM_HISTORY_LENGTH);
|
||
}
|
||
return ans;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
#ifndef HAVE_STRDUP
|
||
static char *
|
||
strdup (char *s)
|
||
{
|
||
size_t len = strlen (s);
|
||
char *new = malloc (len + 1);
|
||
strcpy (new, s);
|
||
return new;
|
||
}
|
||
#endif /* HAVE_STRDUP */
|
||
|
||
#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
|
||
|
||
/* These are readline functions added in release 2.3. They will work
|
||
* together with readline-2.1 and 2.2. (The readline interface is
|
||
* disabled for earlier releases.)
|
||
* They are declared static; if we want to use them elsewhere, then
|
||
* we need external declarations for them, but at the moment, I don't
|
||
* think anything else in Guile ought to use these.
|
||
*/
|
||
|
||
extern void _rl_clean_up_for_exit ();
|
||
extern void _rl_kill_kbd_macro ();
|
||
extern int _rl_init_argument ();
|
||
|
||
void
|
||
rl_cleanup_after_signal ()
|
||
{
|
||
#ifdef HAVE_RL_CLEAR_SIGNALS
|
||
_rl_clean_up_for_exit ();
|
||
#endif
|
||
(*rl_deprep_term_function) ();
|
||
#ifdef HAVE_RL_CLEAR_SIGNALS
|
||
rl_clear_signals ();
|
||
#endif
|
||
rl_pending_input = 0;
|
||
}
|
||
|
||
void
|
||
rl_free_line_state ()
|
||
{
|
||
register HIST_ENTRY *entry;
|
||
|
||
free_undo_list ();
|
||
|
||
entry = current_history ();
|
||
if (entry)
|
||
entry->data = (char *)NULL;
|
||
|
||
_rl_kill_kbd_macro ();
|
||
rl_clear_message ();
|
||
_rl_init_argument ();
|
||
}
|
||
|
||
#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
|
||
|
||
static int promptp;
|
||
static SCM input_port;
|
||
static SCM output_port;
|
||
static SCM before_read;
|
||
|
||
static int
|
||
current_input_getc (FILE *in SCM_UNUSED)
|
||
{
|
||
if (promptp && scm_is_true (before_read))
|
||
{
|
||
scm_apply (before_read, SCM_EOL, SCM_EOL);
|
||
promptp = 0;
|
||
}
|
||
return scm_get_byte_or_eof (input_port);
|
||
}
|
||
|
||
static int in_readline = 0;
|
||
static SCM reentry_barrier_mutex;
|
||
|
||
static SCM internal_readline (SCM text);
|
||
static void unwind_readline (void *unused);
|
||
static void reentry_barrier (void);
|
||
|
||
|
||
SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
|
||
(SCM text, SCM inp, SCM outp, SCM read_hook),
|
||
"")
|
||
#define FUNC_NAME s_scm_readline
|
||
{
|
||
SCM ans;
|
||
|
||
reentry_barrier ();
|
||
|
||
before_read = SCM_BOOL_F;
|
||
|
||
if (!SCM_UNBNDP (text))
|
||
{
|
||
if (!scm_is_string (text))
|
||
{
|
||
--in_readline;
|
||
scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
|
||
}
|
||
}
|
||
|
||
if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_current_input_port ()))
|
||
|| SCM_OPINFPORTP (inp)))
|
||
{
|
||
--in_readline;
|
||
scm_misc_error (s_scm_readline,
|
||
"Input port is not open or not a file port",
|
||
SCM_EOL);
|
||
}
|
||
|
||
if (!((SCM_UNBNDP (outp) && SCM_OPOUTFPORTP (scm_current_output_port ()))
|
||
|| SCM_OPOUTFPORTP (outp)))
|
||
{
|
||
--in_readline;
|
||
scm_misc_error (s_scm_readline,
|
||
"Output port is not open or not a file port",
|
||
SCM_EOL);
|
||
}
|
||
|
||
if (!(SCM_UNBNDP (read_hook) || scm_is_false (read_hook)))
|
||
{
|
||
if (scm_is_false (scm_thunk_p (read_hook)))
|
||
{
|
||
--in_readline;
|
||
scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
|
||
}
|
||
before_read = read_hook;
|
||
}
|
||
|
||
scm_readline_init_ports (inp, outp);
|
||
|
||
scm_dynwind_begin (0);
|
||
scm_dynwind_unwind_handler (unwind_readline, NULL, 0);
|
||
|
||
ans = internal_readline (text);
|
||
|
||
scm_dynwind_end ();
|
||
|
||
fclose (rl_instream);
|
||
fclose (rl_outstream);
|
||
|
||
--in_readline;
|
||
return ans;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
static void
|
||
reentry_barrier ()
|
||
{
|
||
int reentryp = 0;
|
||
/* We should rather use scm_try_mutex when it becomes available */
|
||
scm_lock_mutex (reentry_barrier_mutex);
|
||
if (in_readline)
|
||
reentryp = 1;
|
||
else
|
||
++in_readline;
|
||
scm_unlock_mutex (reentry_barrier_mutex);
|
||
if (reentryp)
|
||
scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
|
||
}
|
||
|
||
/* This function is only called on nonlocal exit from readline(). */
|
||
static void
|
||
unwind_readline (void *unused)
|
||
{
|
||
rl_free_line_state ();
|
||
rl_cleanup_after_signal ();
|
||
fputc ('\n', rl_outstream); /* We don't want next output on this line */
|
||
fclose (rl_instream);
|
||
fclose (rl_outstream);
|
||
--in_readline;
|
||
}
|
||
|
||
static SCM
|
||
internal_readline (SCM text)
|
||
{
|
||
SCM ret;
|
||
char *s;
|
||
char *prompt = SCM_UNBNDP (text) ? "" : scm_to_locale_string (text);
|
||
|
||
promptp = 1;
|
||
s = readline (prompt);
|
||
if (s)
|
||
ret = scm_from_port_string (s, output_port);
|
||
else
|
||
ret = SCM_EOF_VAL;
|
||
|
||
if (!SCM_UNBNDP (text))
|
||
free (prompt);
|
||
free (s);
|
||
|
||
return ret;
|
||
}
|
||
|
||
static FILE *
|
||
stream_from_fport (SCM port, char *mode, const char *subr)
|
||
{
|
||
int fd;
|
||
FILE *f;
|
||
|
||
fd = dup (((struct scm_t_fport *) SCM_STREAM (port))->fdes);
|
||
if (fd == -1)
|
||
{
|
||
--in_readline;
|
||
scm_syserror (subr);
|
||
}
|
||
|
||
f = fdopen (fd, mode);
|
||
if (f == NULL)
|
||
{
|
||
--in_readline;
|
||
scm_syserror (subr);
|
||
}
|
||
|
||
return f;
|
||
}
|
||
|
||
void
|
||
scm_readline_init_ports (SCM inp, SCM outp)
|
||
{
|
||
if (SCM_UNBNDP (inp))
|
||
inp = scm_current_input_port ();
|
||
|
||
if (SCM_UNBNDP (outp))
|
||
outp = scm_current_output_port ();
|
||
|
||
if (!SCM_OPINFPORTP (inp)) {
|
||
scm_misc_error (0,
|
||
"Input port is not open or not a file port",
|
||
SCM_EOL);
|
||
}
|
||
|
||
if (!SCM_OPOUTFPORTP (outp)) {
|
||
scm_misc_error (0,
|
||
"Output port is not open or not a file port",
|
||
SCM_EOL);
|
||
}
|
||
|
||
input_port = inp;
|
||
output_port = outp;
|
||
rl_instream = stream_from_fport (inp, "r", s_scm_readline);
|
||
rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
|
||
}
|
||
|
||
|
||
|
||
SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0,
|
||
(SCM text),
|
||
"")
|
||
#define FUNC_NAME s_scm_add_history
|
||
{
|
||
char* s;
|
||
|
||
s = scm_to_locale_string (text);
|
||
add_history (s);
|
||
free (s);
|
||
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0,
|
||
(SCM file),
|
||
"")
|
||
#define FUNC_NAME s_scm_read_history
|
||
{
|
||
char *filename;
|
||
SCM ret;
|
||
|
||
filename = scm_to_locale_string (file);
|
||
ret = scm_from_bool (!read_history (filename));
|
||
free (filename);
|
||
return ret;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0,
|
||
(SCM file),
|
||
"")
|
||
#define FUNC_NAME s_scm_write_history
|
||
{
|
||
char *filename;
|
||
SCM ret;
|
||
|
||
filename = scm_to_locale_string (file);
|
||
ret = scm_from_bool (!write_history (filename));
|
||
free (filename);
|
||
return ret;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0,
|
||
(),
|
||
"Clear the history buffer of the readline machinery.")
|
||
#define FUNC_NAME s_scm_clear_history
|
||
{
|
||
clear_history();
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0,
|
||
(SCM text, SCM continuep),
|
||
"")
|
||
#define FUNC_NAME s_scm_filename_completion_function
|
||
{
|
||
char *s;
|
||
char *c_text = scm_to_locale_string (text);
|
||
#ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
|
||
s = rl_filename_completion_function (c_text, scm_is_true (continuep));
|
||
#else
|
||
s = filename_completion_function (c_text, scm_is_true (continuep));
|
||
#endif
|
||
free (c_text);
|
||
if (!s)
|
||
return SCM_BOOL_F;
|
||
|
||
return scm_take_locale_string (s);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
/*
|
||
* The following has been modified from code contributed by
|
||
* Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
|
||
*/
|
||
|
||
SCM scm_readline_completion_function_var;
|
||
|
||
static char *
|
||
completion_function (char *text, int continuep)
|
||
{
|
||
SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var);
|
||
SCM res;
|
||
|
||
if (scm_is_false (compfunc))
|
||
return NULL; /* #f => completion disabled */
|
||
else
|
||
{
|
||
SCM t = scm_from_locale_string (text);
|
||
SCM c = scm_from_bool (continuep);
|
||
res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
|
||
|
||
if (scm_is_false (res))
|
||
return NULL;
|
||
|
||
return scm_to_locale_string (res);
|
||
}
|
||
}
|
||
|
||
#if HAVE_RL_GET_KEYMAP_NAME
|
||
/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/
|
||
|
||
static int match_paren (int x, int k);
|
||
static int find_matching_paren (int k);
|
||
static void init_bouncing_parens ();
|
||
|
||
static void
|
||
init_bouncing_parens ()
|
||
{
|
||
Keymap km = rl_get_keymap ();
|
||
if (km)
|
||
{
|
||
if (strncmp (rl_get_keymap_name (km), "vi", 2))
|
||
{
|
||
rl_bind_key (')', match_paren);
|
||
rl_bind_key (']', match_paren);
|
||
rl_bind_key ('}', match_paren);
|
||
}
|
||
}
|
||
else
|
||
scm_error (scm_misc_error_key, "", "readline has not been properly initialized",
|
||
SCM_EOL, SCM_EOL);
|
||
}
|
||
|
||
static int
|
||
find_matching_paren(int k)
|
||
{
|
||
register int i;
|
||
register char c = 0;
|
||
int end_parens_found = 0;
|
||
|
||
/* Choose the corresponding opening bracket. */
|
||
if (k == ')') c = '(';
|
||
else if (k == ']') c = '[';
|
||
else if (k == '}') c = '{';
|
||
|
||
for (i=rl_point-2; i>=0; i--)
|
||
{
|
||
/* Is the current character part of a character literal? */
|
||
if (i - 2 >= 0
|
||
&& rl_line_buffer[i - 1] == '\\'
|
||
&& rl_line_buffer[i - 2] == '#')
|
||
;
|
||
else if (rl_line_buffer[i] == k)
|
||
end_parens_found++;
|
||
else if (rl_line_buffer[i] == '"')
|
||
{
|
||
/* Skip over a string literal. */
|
||
for (i--; i >= 0; i--)
|
||
if (rl_line_buffer[i] == '"'
|
||
&& ! (i - 1 >= 0
|
||
&& rl_line_buffer[i - 1] == '\\'))
|
||
break;
|
||
}
|
||
else if (rl_line_buffer[i] == c)
|
||
{
|
||
if (end_parens_found==0)
|
||
return i;
|
||
else --end_parens_found;
|
||
}
|
||
}
|
||
return -1;
|
||
}
|
||
|
||
static int
|
||
match_paren (int x, int k)
|
||
{
|
||
int tmp;
|
||
int fno;
|
||
fd_set readset;
|
||
struct timeval timeout;
|
||
|
||
rl_insert (x, k);
|
||
if (!SCM_READLINE_BOUNCE_PARENS)
|
||
return 0;
|
||
|
||
/* Did we just insert a quoted paren? If so, then don't bounce. */
|
||
if (rl_point - 1 >= 1
|
||
&& rl_line_buffer[rl_point - 2] == '\\')
|
||
return 0;
|
||
|
||
tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
|
||
timeout.tv_sec = tmp / 1000000;
|
||
timeout.tv_usec = tmp % 1000000;
|
||
FD_ZERO (&readset);
|
||
fno = fileno (rl_instream);
|
||
FD_SET (fno, &readset);
|
||
|
||
if (rl_point > 1)
|
||
{
|
||
tmp = rl_point;
|
||
rl_point = find_matching_paren (k);
|
||
if (rl_point > -1)
|
||
{
|
||
rl_redisplay ();
|
||
select (fno + 1, &readset, NULL, NULL, &timeout);
|
||
}
|
||
rl_point = tmp;
|
||
}
|
||
return 0;
|
||
}
|
||
#endif /* HAVE_RL_GET_KEYMAP_NAME */
|
||
|
||
#endif /* HAVE_RL_GETC_FUNCTION */
|
||
|
||
void
|
||
scm_init_readline ()
|
||
{
|
||
#ifdef HAVE_RL_GETC_FUNCTION
|
||
#include "guile-readline/readline.x"
|
||
scm_readline_completion_function_var
|
||
= scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
|
||
rl_getc_function = current_input_getc;
|
||
#if defined (_RL_FUNCTION_TYPEDEF)
|
||
rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
|
||
#else
|
||
rl_completion_entry_function = (Function*) completion_function;
|
||
#endif
|
||
rl_basic_word_break_characters = " \t\n\"'`;()";
|
||
rl_readline_name = "Guile";
|
||
|
||
/* Let Guile handle signals. */
|
||
#if defined (HAVE_DECL_RL_CATCH_SIGNALS) && HAVE_DECL_RL_CATCH_SIGNALS
|
||
rl_catch_signals = 0;
|
||
#endif
|
||
|
||
/* But let readline handle SIGWINCH. */
|
||
#if defined (HAVE_DECL_RL_CATCH_SIGWINCH) && HAVE_DECL_RL_CATCH_SIGWINCH
|
||
rl_catch_sigwinch = 1;
|
||
#endif
|
||
|
||
reentry_barrier_mutex = scm_make_mutex ();
|
||
scm_init_opts (scm_readline_options,
|
||
scm_readline_opts);
|
||
rl_variable_bind ("enable-bracketed-paste",
|
||
SCM_READLINE_BRACKETED_PASTE ? "on" : "off");
|
||
|
||
#if HAVE_RL_GET_KEYMAP_NAME
|
||
init_bouncing_parens();
|
||
#endif
|
||
scm_add_feature ("readline");
|
||
#endif /* HAVE_RL_GETC_FUNCTION */
|
||
}
|
||
|
||
/*
|
||
Local Variables:
|
||
c-file-style: "gnu"
|
||
End:
|
||
*/
|