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