libguile/readline.c

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