guile-readline/readline.c

   1 /* readline.c --- line editing support for Guile */
   2
   3 /* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2013 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 3, 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 #ifdef HAVE_CONFIG_H
  25 # include <config.h>
  26 #endif
  27
  28 #ifdef HAVE_RL_GETC_FUNCTION
  29 #include "libguile.h"
  30 #include "libguile/iselect.h"
  31
  32 #include <stdio.h>
  33 #ifdef HAVE_UNISTD_H
  34 #include <unistd.h>
  35 #endif
  36 #include <readline/readline.h>
  37 #include <readline/history.h>
  38 #ifndef __MINGW32__
  39 #include <sys/time.h>
  40 #else
  41 #include <io.h>
  42 #endif
  43 #include <signal.h>
  44
  45 #include "libguile/validate.h"
  46 #include "guile-readline/readline.h"
  47
  48 scm_t_option scm_readline_opts[] = {
  49   { SCM_OPTION_BOOLEAN, "history-file", 1,
  50     "Use history file." },
  51   { SCM_OPTION_INTEGER, "history-length", 200,
  52     "History length." },
  53   { SCM_OPTION_INTEGER, "bounce-parens", 500,
  54     "Time (ms) to show matching opening parenthesis (0 = off)."},
  55   { 0 }
  56 };
  57
  58 extern void stifle_history (int max);
  59
  60 SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
  61             (SCM setting),
  62 "")
  63 #define FUNC_NAME s_scm_readline_options
  64 {
  65   SCM ans = scm_options (setting,
  66                          scm_readline_opts,
  67                          FUNC_NAME);
  68   stifle_history (SCM_HISTORY_LENGTH);
  69   return ans;
  70 }
  71 #undef FUNC_NAME
  72
  73 #ifndef HAVE_STRDUP
  74 static char *
  75 strdup (char *s)
  76 {
  77   size_t len = strlen (s);
  78   char *new = malloc (len + 1);
  79   strcpy (new, s);
  80   return new;
  81 }
  82 #endif /* HAVE_STRDUP */
  83
  84 #ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
  85
  86 /* These are readline functions added in release 2.3.  They will work
  87  * together with readline-2.1 and 2.2.  (The readline interface is
  88  * disabled for earlier releases.)
  89  * They are declared static; if we want to use them elsewhere, then
  90  * we need external declarations for them, but at the moment, I don't
  91  * think anything else in Guile ought to use these.
  92  */
  93
  94 extern void _rl_clean_up_for_exit ();
  95 extern void _rl_kill_kbd_macro ();
  96 extern int _rl_init_argument ();
  97
  98 void
  99 rl_cleanup_after_signal ()
 100 {
 101 #ifdef HAVE_RL_CLEAR_SIGNALS
 102   _rl_clean_up_for_exit ();
 103 #endif
 104   (*rl_deprep_term_function) ();
 105 #ifdef HAVE_RL_CLEAR_SIGNALS
 106   rl_clear_signals ();
 107 #endif
 108   rl_pending_input = 0;
 109 }
 110
 111 void
 112 rl_free_line_state ()
 113 {
 114   register HIST_ENTRY *entry;
 115
 116   free_undo_list ();
 117
 118   entry = current_history ();
 119   if (entry)
 120     entry->data = (char *)NULL;
 121
 122   _rl_kill_kbd_macro ();
 123   rl_clear_message ();
 124   _rl_init_argument ();
 125 }
 126
 127 #endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
 128
 129 static int promptp;
 130 static SCM input_port;
 131 static SCM output_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_get_byte_or_eof (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 void unwind_readline (void *unused);
 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   scm_dynwind_begin (0);
 204   scm_dynwind_unwind_handler (unwind_readline, NULL, 0);
 205
 206   ans = internal_readline (text);
 207
 208   scm_dynwind_end ();
 209
 210 #ifndef __MINGW32__
 211   fclose (rl_instream);
 212   fclose (rl_outstream);
 213 #endif
 214
 215   --in_readline;
 216   return ans;
 217 }
 218 #undef FUNC_NAME
 219
 220
 221 static void
 222 reentry_barrier ()
 223 {
 224   int reentryp = 0;
 225   /* We should rather use scm_try_mutex when it becomes available */
 226   scm_lock_mutex (reentry_barrier_mutex);
 227   if (in_readline)
 228     reentryp = 1;
 229   else
 230     ++in_readline;
 231   scm_unlock_mutex (reentry_barrier_mutex);
 232   if (reentryp)
 233     scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
 234 }
 235
 236 /* This function is only called on nonlocal exit from readline(). */
 237 static void
 238 unwind_readline (void *unused)
 239 {
 240   rl_free_line_state ();
 241   rl_cleanup_after_signal ();
 242   fputc ('\n', rl_outstream); /* We don't want next output on this line */
 243 #ifndef __MINGW32__
 244   fclose (rl_instream);
 245   fclose (rl_outstream);
 246 #endif
 247   --in_readline;
 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_port_string (s, output_port);
 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   output_port = outp;
 317 #ifndef __MINGW32__
 318   rl_instream = stream_from_fport (inp, "r", s_scm_readline);
 319   rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
 320 #endif
 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
 332   s = scm_to_locale_string (text);
 333   add_history (s);
 334   free (s);
 335
 336   return SCM_UNSPECIFIED;
 337 }
 338 #undef FUNC_NAME
 339
 340
 341 SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0,
 342             (SCM file),
 343 "")
 344 #define FUNC_NAME s_scm_read_history
 345 {
 346   char *filename;
 347   SCM ret;
 348
 349   filename = scm_to_locale_string (file);
 350   ret = scm_from_bool (!read_history (filename));
 351   free (filename);
 352   return ret;
 353 }
 354 #undef FUNC_NAME
 355
 356
 357 SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0,
 358             (SCM file),
 359 "")
 360 #define FUNC_NAME s_scm_write_history
 361 {
 362   char *filename;
 363   SCM ret;
 364
 365   filename = scm_to_locale_string (file);
 366   ret = scm_from_bool (!write_history (filename));
 367   free (filename);
 368   return ret;
 369 }
 370 #undef FUNC_NAME
 371
 372 SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0,
 373             (),
 374             "Clear the history buffer of the readline machinery.")
 375 #define FUNC_NAME s_scm_clear_history
 376 {
 377   clear_history();
 378   return SCM_UNSPECIFIED;
 379 }
 380 #undef FUNC_NAME
 381
 382
 383 SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0,
 384             (SCM text, SCM continuep),
 385 "")
 386 #define FUNC_NAME s_scm_filename_completion_function
 387 {
 388   char *s;
 389   SCM ans;
 390   char *c_text = scm_to_locale_string (text);
 391 #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
 392   s = rl_filename_completion_function (c_text, scm_is_true (continuep));
 393 #else
 394   s = filename_completion_function (c_text, scm_is_true (continuep));
 395 #endif
 396   ans = scm_take_locale_string (s);
 397   free (c_text);
 398   return ans;
 399 }
 400 #undef FUNC_NAME
 401
 402 /*
 403  * The following has been modified from code contributed by
 404  * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
 405  */
 406
 407 SCM scm_readline_completion_function_var;
 408
 409 static char *
 410 completion_function (char *text, int continuep)
 411 {
 412   SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var);
 413   SCM res;
 414
 415   if (scm_is_false (compfunc))
 416     return NULL; /* #f => completion disabled */
 417   else
 418     {
 419       SCM t = scm_from_locale_string (text);
 420       SCM c = scm_from_bool (continuep);
 421       res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
 422
 423       if (scm_is_false (res))
 424         return NULL;
 425
 426       return scm_to_locale_string (res);
 427     }
 428 }
 429
 430 #if HAVE_RL_GET_KEYMAP
 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_std_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 #endif /* HAVE_RL_GET_KEYMAP */
 535
 536 #endif /* HAVE_RL_GETC_FUNCTION */
 537
 538 void
 539 scm_init_readline ()
 540 {
 541 #ifdef HAVE_RL_GETC_FUNCTION
 542 #include "guile-readline/readline.x"
 543   scm_readline_completion_function_var
 544     = scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
 545 #ifndef __MINGW32__
 546   rl_getc_function = current_input_getc;
 547 #endif
 548 #if defined (_RL_FUNCTION_TYPEDEF)
 549   rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
 550 #else
 551   rl_completion_entry_function = (Function*) completion_function;
 552 #endif
 553   rl_basic_word_break_characters = " \t\n\"'`;()";
 554   rl_readline_name = "Guile";
 555
 556   /* Let Guile handle signals. */
 557 #if defined (HAVE_DECL_RL_CATCH_SIGNALS) && HAVE_DECL_RL_CATCH_SIGNALS
 558   rl_catch_signals = 0;
 559 #endif
 560
 561   /* But let readline handle SIGWINCH. */
 562 #if defined (HAVE_DECL_RL_CATCH_SIGWINCH) && HAVE_DECL_RL_CATCH_SIGWINCH
 563   rl_catch_sigwinch = 1;
 564 #endif
 565
 566   reentry_barrier_mutex = scm_make_mutex ();
 567   scm_init_opts (scm_readline_options,
 568                  scm_readline_opts);
 569 #if HAVE_RL_GET_KEYMAP
 570   init_bouncing_parens();
 571 #endif
 572   scm_add_feature ("readline");
 573 #endif /* HAVE_RL_GETC_FUNCTION */
 574 }
 575
 576 /*
 577   Local Variables:
 578   c-file-style: "gnu"
 579   End:
 580 */