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