guile-readline/readline.c

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