guile-readline/readline.c

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