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 \f
  22
  23 #include "libguile/_scm.h"
  24 #if defined (HAVE_RL_GETC_FUNCTION)
  25 #include "libguile/libguile.h"
  26 #include "libguile/gh.h"
  27 #include "libguile/iselect.h"
  28
  29 #include <readline/readline.h>
  30 #include <readline/history.h>
  31 #include <sys/time.h>
  32
  33 #include "readline.h"
  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
  85 void
  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
  98 void
  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 ();
 171   fputc ('\n', rl_outstream); /* We don't want next output on this line */
 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
 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
 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
 266   if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp))
 267         || SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))
 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     }
 274
 275   if (!((SCM_UNBNDP (outp) && SCM_NIMP (scm_cur_outp) && SCM_OPINFPORTP (outp))
 276         || (SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))))
 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
 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);
 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   rl_readline_name = "Guile";
 498
 499 #ifdef USE_THREADS
 500   scm_mutex_init (&reentry_barrier_mutex);
 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