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                          FUNC_NAME);
  69   stifle_history (SCM_HISTORY_LENGTH);
  70   return ans;
  71 }
  72 #undef FUNC_NAME
  73
  74 #ifndef HAVE_STRDUP
  75 static char *
  76 strdup (char *s)
  77 {
  78   size_t len = strlen (s);
  79   char *new = malloc (len + 1);
  80   strcpy (new, s);
  81   return new;
  82 }
  83 #endif /* HAVE_STRDUP */
  84
  85 #ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
  86
  87 /* These are readline functions added in release 2.3.  They will work
  88  * together with readline-2.1 and 2.2.  (The readline interface is
  89  * disabled for earlier releases.)
  90  * They are declared static; if we want to use them elsewhere, then
  91  * we need external declarations for them, but at the moment, I don't
  92  * think anything else in Guile ought to use these.
  93  */
  94
  95 extern void _rl_clean_up_for_exit ();
  96 extern void _rl_kill_kbd_macro ();
  97 extern int _rl_init_argument ();
  98
  99 void
 100 rl_cleanup_after_signal ()
 101 {
 102 #ifdef HAVE_RL_CLEAR_SIGNALS
 103   _rl_clean_up_for_exit ();
 104 #endif
 105   (*rl_deprep_term_function) ();
 106 #ifdef HAVE_RL_CLEAR_SIGNALS
 107   rl_clear_signals ();
 108 #endif
 109   rl_pending_input = 0;
 110 }
 111
 112 void
 113 rl_free_line_state ()
 114 {
 115   register HIST_ENTRY *entry;
 116
 117   free_undo_list ();
 118
 119   entry = current_history ();
 120   if (entry)
 121     entry->data = (char *)NULL;
 122
 123   _rl_kill_kbd_macro ();
 124   rl_clear_message ();
 125   _rl_init_argument ();
 126 }
 127
 128 #endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
 129
 130 static int promptp;
 131 static SCM input_port;
 132 static SCM before_read;
 133
 134 static int
 135 current_input_getc (FILE *in SCM_UNUSED)
 136 {
 137   if (promptp && scm_is_true (before_read))
 138     {
 139       scm_apply (before_read, SCM_EOL, SCM_EOL);
 140       promptp = 0;
 141     }
 142   return scm_getc (input_port);
 143 }
 144
 145 static int in_readline = 0;
 146 static SCM reentry_barrier_mutex;
 147
 148 static SCM internal_readline (SCM text);
 149 static SCM handle_error (void *data, SCM tag, SCM args);
 150 static void reentry_barrier (void);
 151
 152
 153 SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
 154             (SCM text, SCM inp, SCM outp, SCM read_hook),
 155 "")
 156 #define FUNC_NAME s_scm_readline
 157 {
 158   SCM ans;
 159
 160   reentry_barrier ();
 161
 162   before_read = SCM_BOOL_F;
 163
 164   if (!SCM_UNBNDP (text))
 165     {
 166       if (!scm_is_string (text))
 167         {
 168           --in_readline;
 169           scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
 170         }
 171     }
 172
 173   if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_current_input_port ()))
 174         || SCM_OPINFPORTP (inp)))
 175     {
 176       --in_readline;
 177       scm_misc_error (s_scm_readline,
 178                       "Input port is not open or not a file port",
 179                       SCM_EOL);
 180     }
 181
 182   if (!((SCM_UNBNDP (outp) && SCM_OPOUTFPORTP (scm_current_output_port ()))
 183         || SCM_OPOUTFPORTP (outp)))
 184     {
 185       --in_readline;
 186       scm_misc_error (s_scm_readline,
 187                       "Output port is not open or not a file port",
 188                       SCM_EOL);
 189     }
 190
 191   if (!(SCM_UNBNDP (read_hook) || scm_is_false (read_hook)))
 192     {
 193       if (scm_is_false (scm_thunk_p (read_hook)))
 194         {
 195           --in_readline;
 196           scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
 197         }
 198       before_read = read_hook;
 199     }
 200
 201   scm_readline_init_ports (inp, outp);
 202
 203   ans = scm_internal_catch (SCM_BOOL_T,
 204                             (scm_t_catch_body) internal_readline,
 205                             (void *) SCM_UNPACK (text),
 206                             handle_error, 0);
 207
 208 #ifndef __MINGW32__
 209   fclose (rl_instream);
 210   fclose (rl_outstream);
 211 #endif
 212
 213   --in_readline;
 214   return ans;
 215 }
 216 #undef FUNC_NAME
 217
 218
 219 static void
 220 reentry_barrier ()
 221 {
 222   int reentryp = 0;
 223   /* We should rather use scm_try_mutex when it becomes available */
 224   scm_lock_mutex (reentry_barrier_mutex);
 225   if (in_readline)
 226     reentryp = 1;
 227   else
 228     ++in_readline;
 229   scm_unlock_mutex (reentry_barrier_mutex);
 230   if (reentryp)
 231     scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
 232 }
 233
 234 static SCM
 235 handle_error (void *data, SCM tag, SCM args)
 236 {
 237   rl_free_line_state ();
 238   rl_cleanup_after_signal ();
 239   fputc ('\n', rl_outstream); /* We don't want next output on this line */
 240 #ifndef __MINGW32__
 241   fclose (rl_instream);
 242   fclose (rl_outstream);
 243 #endif
 244   --in_readline;
 245   scm_handle_by_throw (data, tag, args);
 246   return SCM_UNSPECIFIED; /* never reached */
 247 }
 248
 249 static SCM
 250 internal_readline (SCM text)
 251 {
 252   SCM ret;
 253   char *s;
 254   char *prompt = SCM_UNBNDP (text) ? "" : scm_to_locale_string (text);
 255
 256   promptp = 1;
 257   s = readline (prompt);
 258   if (s)
 259     ret = scm_from_locale_string (s);
 260   else
 261     ret = SCM_EOF_VAL;
 262
 263   if (!SCM_UNBNDP (text))
 264     free (prompt);
 265   free (s);
 266
 267   return ret;
 268 }
 269
 270 static FILE *
 271 stream_from_fport (SCM port, char *mode, const char *subr)
 272 {
 273   int fd;
 274   FILE *f;
 275
 276   fd = dup (((struct scm_t_fport *) SCM_STREAM (port))->fdes);
 277   if (fd == -1)
 278     {
 279       --in_readline;
 280       scm_syserror (subr);
 281     }
 282
 283   f = fdopen (fd, mode);
 284   if (f == NULL)
 285     {
 286       --in_readline;
 287       scm_syserror (subr);
 288     }
 289
 290   return f;
 291 }
 292
 293 void
 294 scm_readline_init_ports (SCM inp, SCM outp)
 295 {
 296   if (SCM_UNBNDP (inp))
 297     inp = scm_current_input_port ();
 298
 299   if (SCM_UNBNDP (outp))
 300     outp = scm_current_output_port ();
 301
 302   if (!SCM_OPINFPORTP (inp)) {
 303     scm_misc_error (0,
 304                     "Input port is not open or not a file port",
 305                     SCM_EOL);
 306   }
 307
 308   if (!SCM_OPOUTFPORTP (outp)) {
 309     scm_misc_error (0,
 310                     "Output port is not open or not a file port",
 311                     SCM_EOL);
 312   }
 313
 314   input_port = inp;
 315 #ifndef __MINGW32__
 316   rl_instream = stream_from_fport (inp, "r", s_scm_readline);
 317   rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
 318 #endif
 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
 330   s = scm_to_locale_string (text);
 331   add_history (s);
 332
 333   return SCM_UNSPECIFIED;
 334 }
 335 #undef FUNC_NAME
 336
 337
 338 SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0,
 339             (SCM file),
 340 "")
 341 #define FUNC_NAME s_scm_read_history
 342 {
 343   char *filename;
 344   SCM ret;
 345
 346   filename = scm_to_locale_string (file);
 347   ret = scm_from_bool (!read_history (filename));
 348   free (filename);
 349   return ret;
 350 }
 351 #undef FUNC_NAME
 352
 353
 354 SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0,
 355             (SCM file),
 356 "")
 357 #define FUNC_NAME s_scm_write_history
 358 {
 359   char *filename;
 360   SCM ret;
 361
 362   filename = scm_to_locale_string (file);
 363   ret = scm_from_bool (!write_history (filename));
 364   free (filename);
 365   return ret;
 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   char *c_text = scm_to_locale_string (text);
 388 #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
 389   s = rl_filename_completion_function (c_text, scm_is_true (continuep));
 390 #else
 391   s = filename_completion_function (c_text, scm_is_true (continuep));
 392 #endif
 393   ans = scm_take_locale_string (s);
 394   free (c_text);
 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_is_false (compfunc))
 413     return NULL; /* #f => completion disabled */
 414   else
 415     {
 416       SCM t = scm_from_locale_string (text);
 417       SCM c = scm_from_bool (continuep);
 418       res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
 419
 420       if (scm_is_false (res))
 421         return NULL;
 422
 423       return scm_to_locale_string (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;
 488 #ifndef __MINGW32__
 489   int fno;
 490   SELECT_TYPE readset;
 491   struct timeval timeout;
 492 #endif
 493
 494   rl_insert (x, k);
 495   if (!SCM_READLINE_BOUNCE_PARENS)
 496     return 0;
 497
 498   /* Did we just insert a quoted paren?  If so, then don't bounce.  */
 499   if (rl_point - 1 >= 1
 500       && rl_line_buffer[rl_point - 2] == '\\')
 501     return 0;
 502
 503 #ifndef __MINGW32__
 504   tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
 505   timeout.tv_sec = tmp / 1000000;
 506   timeout.tv_usec = tmp % 1000000;
 507   FD_ZERO (&readset);
 508   fno = fileno (rl_instream);
 509   FD_SET (fno, &readset);
 510 #endif
 511
 512   if (rl_point > 1)
 513     {
 514       tmp = rl_point;
 515       rl_point = find_matching_paren (k);
 516       if (rl_point > -1)
 517         {
 518           rl_redisplay ();
 519 #ifndef __MINGW32__
 520           scm_std_select (fno + 1, &readset, NULL, NULL, &timeout);
 521 #else
 522           WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE),
 523                                SCM_READLINE_BOUNCE_PARENS);
 524 #endif
 525         }
 526       rl_point = tmp;
 527     }
 528   return 0;
 529 }
 530
 531 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 532 /* Readline disables SA_RESTART on SIGWINCH.
 533  * This code turns it back on.
 534  */
 535 static int
 536 sigwinch_enable_restart (void)
 537 {
 538 #ifdef HAVE_SIGINTERRUPT
 539   siginterrupt (SIGWINCH, 0);
 540 #else
 541   struct sigaction action;
 542
 543   sigaction (SIGWINCH, NULL, &action);
 544   action.sa_flags |= SA_RESTART;
 545   sigaction (SIGWINCH, &action, NULL);
 546 #endif
 547   return 0;
 548 }
 549 #endif
 550
 551 #endif /* HAVE_RL_GETC_FUNCTION */
 552
 553 void
 554 scm_init_readline ()
 555 {
 556 #ifdef HAVE_RL_GETC_FUNCTION
 557 #include "guile-readline/readline.x"
 558   scm_readline_completion_function_var
 559     = scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
 560 #ifndef __MINGW32__
 561   rl_getc_function = current_input_getc;
 562 #endif
 563 #if defined (_RL_FUNCTION_TYPEDEF)
 564   rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
 565 #else
 566   rl_completion_entry_function = (Function*) completion_function;
 567 #endif
 568   rl_basic_word_break_characters = "\t\n\"'`;()";
 569   rl_readline_name = "Guile";
 570 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 571   rl_pre_input_hook = sigwinch_enable_restart;
 572 #endif
 573
 574   reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
 575   scm_init_opts (scm_readline_options,
 576                  scm_readline_opts);
 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 */