Commit | Line | Data |
---|---|---|
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 | |
35 | scm_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 | ||
44 | extern void stifle_history (int max); | |
45 | ||
46 | SCM_PROC (s_readline_options, "readline-options-interface", 0, 1, 0, scm_readline_options); | |
47 | ||
48 | SCM | |
49 | scm_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 | |
61 | static char * | |
62 | strdup (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 | ||
81 | extern void _rl_clean_up_for_exit (); | |
82 | extern void _rl_kill_kbd_macro (); | |
83 | extern int _rl_init_argument (); | |
84 | ||
2e3d5987 | 85 | void |
c374ab69 MV |
86 | rl_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 | 98 | void |
c374ab69 MV |
99 | rl_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 | ||
116 | static int promptp; | |
117 | static SCM input_port; | |
118 | static SCM before_read; | |
119 | ||
120 | static int | |
121 | current_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 | ||
133 | static void | |
134 | redisplay () | |
135 | { | |
136 | rl_redisplay (); | |
137 | /* promptp = 1; */ | |
138 | } | |
139 | ||
140 | SCM_PROC (s_readline, "readline", 0, 4, 0, scm_readline); | |
141 | ||
142 | static int in_readline = 0; | |
143 | #ifdef USE_THREADS | |
144 | static scm_mutex_t reentry_barrier_mutex; | |
145 | #endif | |
146 | ||
147 | static void | |
148 | reentry_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 | ||
166 | static SCM | |
167 | handle_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 | ||
179 | static SCM | |
180 | internal_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 | ||
198 | static FILE * | |
199 | stream_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 |
221 | void |
222 | scm_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 |
247 | SCM |
248 | scm_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 | ||
308 | SCM_PROC (s_add_history, "add-history", 1, 0, 0, scm_add_history); | |
309 | ||
310 | SCM | |
311 | scm_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 | ||
325 | SCM_PROC (s_read_history, "read-history", 1, 0, 0, scm_read_history); | |
326 | ||
327 | SCM | |
328 | scm_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 | ||
336 | SCM_PROC (s_write_history, "write-history", 1, 0, 0, scm_write_history); | |
337 | ||
338 | SCM | |
339 | scm_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 | ||
347 | SCM_PROC (s_filename_completion_function, "filename-completion-function", 2, 0, 0, scm_filename_completion_function); | |
348 | ||
349 | SCM | |
350 | scm_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 | ||
370 | SCM scm_readline_completion_function_var; | |
371 | ||
372 | static char * | |
373 | completion_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 | ||
400 | static void match_paren(int x, int k); | |
401 | static int find_matching_paren(int k); | |
402 | static void init_bouncing_parens(); | |
403 | ||
404 | static void | |
405 | init_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 | ||
414 | static int | |
415 | find_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 | ||
453 | static void | |
454 | match_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 | ||
487 | void | |
488 | scm_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\"'`;()"; | |
497 | #ifdef USE_THREADS | |
2e3d5987 | 498 | scm_mutex_init (&reentry_barrier_mutex, NULL); |
c374ab69 MV |
499 | #endif |
500 | scm_init_opts (scm_readline_options, | |
501 | scm_readline_opts, | |
502 | SCM_N_READLINE_OPTIONS); | |
503 | init_bouncing_parens(); | |
504 | scm_add_feature ("readline"); | |
505 | } | |
506 | ||
507 | #endif |