guile-readline/readline.c

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