* configure.in: check for hstrerror.
[bpt/guile.git] / guile-readline / readline.c
CommitLineData
c374ab69
MV
1/* readline.c --- line editing support for Guile */
2
3/* Copyright (C) 1997,1999 Free Software Foundation, Inc.
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2, or (at your option)
8 * any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this software; see the file COPYING. If not, write to
c6e23ea2
JB
17 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 * Boston, MA 02111-1307 USA
c374ab69
MV
19 *
20 */
21\f
22
739b3bf1 23#include "libguile/_scm.h"
c374ab69 24#if defined (HAVE_RL_GETC_FUNCTION)
739b3bf1
MD
25#include "libguile/libguile.h"
26#include "libguile/gh.h"
27#include "libguile/iselect.h"
28
c374ab69
MV
29#include <readline/readline.h>
30#include <readline/history.h>
c374ab69 31#include <sys/time.h>
c374ab69 32
739b3bf1 33#include "readline.h"
c374ab69
MV
34
35scm_option scm_readline_opts[] = {
36 { SCM_OPTION_BOOLEAN, "history-file", 1,
37 "Use history file." },
38 { SCM_OPTION_INTEGER, "history-length", 200,
39 "History length." },
40 { SCM_OPTION_INTEGER, "bounce-parens", 500,
41 "Time (ms) to show matching opening parenthesis (0 = off)."}
42};
43
44extern void stifle_history (int max);
45
46SCM_PROC (s_readline_options, "readline-options-interface", 0, 1, 0, scm_readline_options);
47
48SCM
49scm_readline_options (setting)
50 SCM setting;
51{
52 SCM ans = scm_options (setting,
53 scm_readline_opts,
54 SCM_N_READLINE_OPTIONS,
55 s_readline_options);
56 stifle_history (SCM_HISTORY_LENGTH);
57 return ans;
58}
59
60#ifndef HAVE_STRDUP
61static char *
62strdup (char *s)
63{
64 int len = strlen (s);
65 char *new = malloc (len + 1);
66 strcpy (new, s);
67 return new;
68}
69#endif /* HAVE_STRDUP */
70
71#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
72
73/* These are readline functions added in release 2.3. They will work
74 * together with readline-2.1 and 2.2. (The readline interface is
75 * disabled for earlier releases.)
76 * They are declared static; if we want to use them elsewhere, then
77 * we need external declarations for them, but at the moment, I don't
78 * think anything else in Guile ought to use these.
79 */
80
81extern void _rl_clean_up_for_exit ();
82extern void _rl_kill_kbd_macro ();
83extern int _rl_init_argument ();
84
2e3d5987 85void
c374ab69
MV
86rl_cleanup_after_signal ()
87{
88#ifdef HAVE_RL_CLEAR_SIGNALS
89 _rl_clean_up_for_exit ();
90#endif
91 (*rl_deprep_term_function) ();
92#ifdef HAVE_RL_CLEAR_SIGNALS
93 rl_clear_signals ();
94#endif
95 rl_pending_input = 0;
96}
97
2e3d5987 98void
c374ab69
MV
99rl_free_line_state ()
100{
101 register HIST_ENTRY *entry;
102
103 free_undo_list ();
104
105 entry = current_history ();
106 if (entry)
107 entry->data = (char *)NULL;
108
109 _rl_kill_kbd_macro ();
110 rl_clear_message ();
111 _rl_init_argument ();
112}
113
114#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
115
116static int promptp;
117static SCM input_port;
118static SCM before_read;
119
120static int
121current_input_getc (FILE *in)
122{
123 SCM ans;
124 if (promptp && SCM_NIMP (before_read))
125 {
126 scm_apply (before_read, SCM_EOL, SCM_EOL);
127 promptp = 0;
128 }
129 ans = scm_getc (input_port);
130 return ans;
131}
132
133static void
134redisplay ()
135{
136 rl_redisplay ();
137 /* promptp = 1; */
138}
139
f98e165e 140SCM_PROC (s_readline, "%readline", 0, 4, 0, scm_readline);
c374ab69
MV
141
142static int in_readline = 0;
143#ifdef USE_THREADS
144static scm_mutex_t reentry_barrier_mutex;
145#endif
146
147static void
148reentry_barrier ()
149{
150 int reentryp = 0;
151#ifdef USE_THREADS
152 /* We should rather use scm_mutex_try_lock when it becomes available */
153 scm_mutex_lock (&reentry_barrier_mutex);
154#endif
155 if (in_readline)
156 reentryp = 1;
157 else
158 ++in_readline;
159#ifdef USE_THREADS
160 scm_mutex_unlock (&reentry_barrier_mutex);
161#endif
162 if (reentryp)
163 scm_misc_error (s_readline, "readline is not reentrant", SCM_EOL);
164}
165
166static SCM
167handle_error (void *data, SCM tag, SCM args)
168{
169 rl_free_line_state ();
170 rl_cleanup_after_signal ();
739b3bf1 171 fputc ('\n', rl_outstream); /* We don't want next output on this line */
c374ab69
MV
172 fclose (rl_instream);
173 fclose (rl_outstream);
174 --in_readline;
175 scm_handle_by_throw (data, tag, args);
176 return SCM_UNSPECIFIED; /* never reached */
177}
178
179static SCM
180internal_readline (SCM text)
181{
182 SCM ret;
183 char *s;
184 char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text);
185
186 promptp = 1;
187 s = readline (prompt);
188 if (s)
189 ret = scm_makfrom0str (s);
190 else
191 ret = SCM_EOF_VAL;
192
193 free (s);
194
195 return ret;
196}
197
198static FILE *
199stream_from_fport (SCM port, char *mode, const char *subr)
200{
201 int fd;
202 FILE *f;
203
204 fd = dup (((struct scm_fport *) SCM_STREAM (port))->fdes);
205 if (fd == -1)
206 {
207 --in_readline;
208 scm_syserror (subr);
209 }
210
211 f = fdopen (fd, mode);
212 if (f == NULL)
213 {
214 --in_readline;
215 scm_syserror (subr);
216 }
217
218 return f;
219}
220
2e3d5987
MD
221void
222scm_readline_init_ports (SCM inp, SCM outp)
223{
224 if (SCM_UNBNDP (inp))
225 inp = scm_cur_inp;
226
227 if (SCM_UNBNDP (outp))
228 outp = scm_cur_outp;
229
230 if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp))) {
231 scm_misc_error (0,
232 "Input port is not open or not a file port",
233 SCM_EOL);
234 }
235
236 if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))) {
237 scm_misc_error (0,
238 "Output port is not open or not a file port",
239 SCM_EOL);
240 }
241
242 input_port = inp;
243 rl_instream = stream_from_fport (inp, "r", s_readline);
244 rl_outstream = stream_from_fport (outp, "w", s_readline);
245}
246
c374ab69
MV
247SCM
248scm_readline (SCM text, SCM inp, SCM outp, SCM read_hook)
249{
250 SCM ans;
251
252 reentry_barrier ();
253
254 before_read = SCM_BOOL_F;
255
256 if (!SCM_UNBNDP (text))
257 {
258 if (!(SCM_NIMP (text) && SCM_STRINGP (text)))
259 {
260 --in_readline;
261 scm_wrong_type_arg (s_readline, SCM_ARG1, text);
262 }
263 SCM_COERCE_SUBSTR (text);
264 }
265
2e3d5987
MD
266 if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp))
267 || SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))
c374ab69
MV
268 {
269 --in_readline;
270 scm_misc_error (s_readline,
271 "Input port is not open or not a file port",
272 SCM_EOL);
273 }
2e3d5987
MD
274
275 if (!((SCM_UNBNDP (outp) && SCM_NIMP (scm_cur_outp) && SCM_OPINFPORTP (outp))
276 || (SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))))
c374ab69
MV
277 {
278 --in_readline;
279 scm_misc_error (s_readline,
280 "Output port is not open or not a file port",
281 SCM_EOL);
282 }
283
2e3d5987
MD
284 if (!(SCM_UNBNDP (read_hook) || SCM_FALSEP (read_hook)))
285 {
286 if (!(SCM_NFALSEP (scm_thunk_p (read_hook))))
287 {
288 --in_readline;
289 scm_wrong_type_arg (s_readline, SCM_ARG4, read_hook);
290 }
291 before_read = read_hook;
292 }
293
294 scm_readline_init_ports (inp, outp);
c374ab69
MV
295
296 ans = scm_internal_catch (SCM_BOOL_T,
297 (scm_catch_body_t) internal_readline,
298 (void *) text,
299 handle_error, 0);
300
301 fclose (rl_instream);
302 fclose (rl_outstream);
303
304 --in_readline;
305 return ans;
306}
307
308SCM_PROC (s_add_history, "add-history", 1, 0, 0, scm_add_history);
309
310SCM
311scm_add_history (SCM text)
312{
313 char* s;
314 SCM_ASSERT ((SCM_NIMP(text) && SCM_STRINGP(text)), text, SCM_ARG1,
315 s_add_history);
316 SCM_COERCE_SUBSTR (text);
317
318 s = SCM_CHARS (text);
319 add_history (strdup (s));
320
321 return SCM_UNSPECIFIED;
322}
323
324
325SCM_PROC (s_read_history, "read-history", 1, 0, 0, scm_read_history);
326
327SCM
328scm_read_history (SCM file)
329{
330 SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file),
331 file, SCM_ARG1, s_read_history);
332 return read_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T;
333}
334
335
336SCM_PROC (s_write_history, "write-history", 1, 0, 0, scm_write_history);
337
338SCM
339scm_write_history (SCM file)
340{
341 SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file),
342 file, SCM_ARG1, s_write_history);
343 return write_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T;
344}
345
346
347SCM_PROC (s_filename_completion_function, "filename-completion-function", 2, 0, 0, scm_filename_completion_function);
348
349SCM
350scm_filename_completion_function (SCM text, SCM continuep)
351{
352 char *s;
353 SCM ans;
354 SCM_ASSERT (SCM_NIMP (text) && SCM_STRINGP (text),
355 text,
356 SCM_ARG1,
357 s_filename_completion_function);
358 SCM_COERCE_SUBSTR (text);
359 s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep));
360 ans = scm_makfrom0str (s);
361 free (s);
362 return ans;
363}
364
365/*
366 * The following has been modified from code contributed by
367 * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
368 */
369
370SCM scm_readline_completion_function_var;
371
372static char *
373completion_function (char *text, int continuep)
374{
375 SCM compfunc = SCM_CDR (scm_readline_completion_function_var);
376 SCM res;
377
378 if (SCM_FALSEP (compfunc))
379 return NULL; /* #f => completion disabled */
380 else
381 {
382 SCM t = scm_makfrom0str (text);
383 SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F;
384 res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL);
385
386 if (SCM_FALSEP (res))
387 return NULL;
388
389 if (!(SCM_NIMP (res) && SCM_STRINGP (res)))
390 scm_misc_error (s_readline,
391 "Completion function returned bogus value: %S",
392 SCM_LIST1 (res));
393 SCM_COERCE_SUBSTR (res);
394 return strdup (SCM_CHARS (res));
395 }
396}
397
398/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/
399
400static void match_paren(int x, int k);
401static int find_matching_paren(int k);
402static void init_bouncing_parens();
403
404static void
405init_bouncing_parens()
406{
407 if(strncmp(rl_get_keymap_name(rl_get_keymap()), "vi", 2)) {
408 rl_bind_key(')', match_paren);
409 rl_bind_key(']', match_paren);
410 rl_bind_key('}', match_paren);
411 }
412}
413
414static int
415find_matching_paren(int k)
416{
417 register int i;
418 register char c = 0;
419 int end_parens_found = 0;
420
421 /* Choose the corresponding opening bracket. */
422 if (k == ')') c = '(';
423 else if (k == ']') c = '[';
424 else if (k == '}') c = '{';
425
426 for (i=rl_point-2; i>=0; i--)
427 {
428 /* Is the current character part of a character literal? */
429 if (i - 2 >= 0
430 && rl_line_buffer[i - 1] == '\\'
431 && rl_line_buffer[i - 2] == '#')
432 ;
433 else if (rl_line_buffer[i] == k)
434 end_parens_found++;
435 else if (rl_line_buffer[i] == '"')
436 {
437 /* Skip over a string literal. */
438 for (i--; i >= 0; i--)
439 if (rl_line_buffer[i] == '"'
440 && ! (i - 1 >= 0
441 && rl_line_buffer[i - 1] == '\\'))
442 break;
443 }
444 else if (rl_line_buffer[i] == c)
445 {
446 if (end_parens_found==0) return i;
447 else --end_parens_found;
448 }
449 }
450 return -1;
451}
452
453static void
454match_paren(int x, int k)
455{
456 int tmp;
457 fd_set readset;
458 struct timeval timeout;
459
460 rl_insert(x, k);
461 if (!SCM_READLINE_BOUNCE_PARENS)
462 return;
463
464 /* Did we just insert a quoted paren? If so, then don't bounce. */
465 if (rl_point - 1 >= 1
466 && rl_line_buffer[rl_point - 2] == '\\')
467 return;
468
469 tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
470 timeout.tv_sec = tmp / 1000000;
471 timeout.tv_usec = tmp % 1000000;
472 FD_ZERO(&readset);
473 FD_SET(fileno(rl_instream), &readset);
474
475 if(rl_point > 1) {
476 tmp = rl_point;
477 rl_point = find_matching_paren(k);
478 if(rl_point > -1) {
479 rl_redisplay();
480 scm_internal_select(1, &readset, NULL, NULL, &timeout);
481 }
482 rl_point = tmp;
483 }
484}
485
486
487void
488scm_init_readline ()
489{
490#include "readline.x"
491 scm_readline_completion_function_var
492 = scm_sysintern ("*readline-completion-function*", SCM_BOOL_F);
493 rl_getc_function = current_input_getc;
494 rl_redisplay_function = redisplay;
495 rl_completion_entry_function = (Function*) completion_function;
496 rl_basic_word_break_characters = "\t\n\"'`;()";
5c11cc9d
GH
497 rl_readline_name = "Guile";
498
c374ab69 499#ifdef USE_THREADS
28c12e2a 500 scm_mutex_init (&reentry_barrier_mutex);
c374ab69
MV
501#endif
502 scm_init_opts (scm_readline_options,
503 scm_readline_opts,
504 SCM_N_READLINE_OPTIONS);
505 init_bouncing_parens();
506 scm_add_feature ("readline");
507}
508
509#endif