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