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