123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574 |
- /* 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:
- */
|