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