guile-readline/readline.c

   1 /* readline.c --- line editing support for Guile */
   2
   3 /* Copyright (C) 1997,1999,2000,2001, 2002 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 static SCM reentry_barrier_mutex;
 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     }
 177
 178   if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_cur_inp))
 179         || 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_OPOUTFPORTP (scm_cur_outp))
 188         || 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_t_catch_body) internal_readline,
 210                             (void *) SCM_UNPACK (text),
 211                             handle_error, 0);
 212
 213 #ifndef __MINGW32__
 214   fclose (rl_instream);
 215   fclose (rl_outstream);
 216 #endif
 217
 218   --in_readline;
 219   return ans;
 220 }
 221 #undef FUNC_NAME
 222
 223
 224 static void
 225 reentry_barrier ()
 226 {
 227   int reentryp = 0;
 228   /* We should rather use scm_try_mutex when it becomes available */
 229   scm_lock_mutex (reentry_barrier_mutex);
 230   if (in_readline)
 231     reentryp = 1;
 232   else
 233     ++in_readline;
 234   scm_unlock_mutex (reentry_barrier_mutex);
 235   if (reentryp)
 236     scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
 237 }
 238
 239 static SCM
 240 handle_error (void *data, SCM tag, SCM args)
 241 {
 242   rl_free_line_state ();
 243   rl_cleanup_after_signal ();
 244   fputc ('\n', rl_outstream); /* We don't want next output on this line */
 245 #ifndef __MINGW32__
 246   fclose (rl_instream);
 247   fclose (rl_outstream);
 248 #endif
 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_t_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_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_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 #ifndef __MINGW32__
 319   rl_instream = stream_from_fport (inp, "r", s_scm_readline);
 320   rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
 321 #endif
 322 }
 323
 324
 325
 326 SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0,
 327             (SCM text),
 328 "")
 329 #define FUNC_NAME s_scm_add_history
 330 {
 331   char* s;
 332   SCM_VALIDATE_STRING (1,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 #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
 383   s = rl_filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep));
 384 #else
 385   s = filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep));
 386 #endif
 387   ans = scm_makfrom0str (s);
 388   free (s);
 389   return ans;
 390 }
 391 #undef FUNC_NAME
 392
 393 /*
 394  * The following has been modified from code contributed by
 395  * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
 396  */
 397
 398 SCM scm_readline_completion_function_var;
 399
 400 static char *
 401 completion_function (char *text, int continuep)
 402 {
 403   SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var);
 404   SCM res;
 405
 406   if (SCM_FALSEP (compfunc))
 407     return NULL; /* #f => completion disabled */
 408   else
 409     {
 410       SCM t = scm_makfrom0str (text);
 411       SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F;
 412       res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
 413
 414       if (SCM_FALSEP (res))
 415         return NULL;
 416
 417       if (!SCM_STRINGP (res))
 418         scm_misc_error (s_scm_readline,
 419                         "Completion function returned bogus value: %S",
 420                         scm_list_1 (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;
 486 #ifndef __MINGW32__
 487   int fno;
 488   SELECT_TYPE readset;
 489   struct timeval timeout;
 490 #endif
 491
 492   rl_insert (x, k);
 493   if (!SCM_READLINE_BOUNCE_PARENS)
 494     return 0;
 495
 496   /* Did we just insert a quoted paren?  If so, then don't bounce.  */
 497   if (rl_point - 1 >= 1
 498       && rl_line_buffer[rl_point - 2] == '\\')
 499     return 0;
 500
 501 #ifndef __MINGW32__
 502   tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
 503   timeout.tv_sec = tmp / 1000000;
 504   timeout.tv_usec = tmp % 1000000;
 505   FD_ZERO (&readset);
 506   fno = fileno (rl_instream);
 507   FD_SET (fno, &readset);
 508 #endif
 509
 510   if (rl_point > 1)
 511     {
 512       tmp = rl_point;
 513       rl_point = find_matching_paren (k);
 514       if (rl_point > -1)
 515         {
 516           rl_redisplay ();
 517 #ifndef __MINGW32__
 518           scm_internal_select (fno + 1, &readset, NULL, NULL, &timeout);
 519 #else
 520           WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE),
 521                                SCM_READLINE_BOUNCE_PARENS);
 522 #endif
 523         }
 524       rl_point = tmp;
 525     }
 526   return 0;
 527 }
 528
 529 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 530 /* Readline disables SA_RESTART on SIGWINCH.
 531  * This code turns it back on.
 532  */
 533 static int
 534 sigwinch_enable_restart (void)
 535 {
 536 #ifdef HAVE_SIGINTERRUPT
 537   siginterrupt (SIGWINCH, 0);
 538 #else
 539   struct sigaction action;
 540
 541   sigaction (SIGWINCH, NULL, &action);
 542   action.sa_flags |= SA_RESTART;
 543   sigaction (SIGWINCH, &action, NULL);
 544 #endif
 545   return 0;
 546 }
 547 #endif
 548
 549 #endif /* HAVE_RL_GETC_FUNCTION */
 550
 551 void
 552 scm_init_readline ()
 553 {
 554 #ifdef HAVE_RL_GETC_FUNCTION
 555 #include "guile-readline/readline.x"
 556   scm_readline_completion_function_var
 557     = scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
 558 #ifndef __MINGW32__
 559   rl_getc_function = current_input_getc;
 560 #endif
 561   rl_redisplay_function = redisplay;
 562 #if defined (_RL_FUNCTION_TYPEDEF)
 563   rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
 564 #else
 565   rl_completion_entry_function = (Function*) completion_function;
 566 #endif
 567   rl_basic_word_break_characters = "\t\n\"'`;()";
 568   rl_readline_name = "Guile";
 569 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 570   rl_pre_input_hook = sigwinch_enable_restart;
 571 #endif
 572
 573   reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
 574   scm_init_opts (scm_readline_options,
 575                  scm_readline_opts,
 576                  SCM_N_READLINE_OPTIONS);
 577   init_bouncing_parens();
 578   scm_add_feature ("readline");
 579 #endif /* HAVE_RL_GETC_FUNCTION */
 580 }
 581
 582 /*
 583   Local Variables:
 584   c-file-style: "gnu"
 585   End:
 586 */