guile-readline/readline.c

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