guile-readline/readline.c

   1 /* readline.c --- line editing support for Guile */
   2
   3 /* Copyright (C) 1997,1999,2000,2001, 2002, 2003 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., 59 Temple Place, Suite 330,
  18  * Boston, MA 02111-1307 USA
  19  *
  20  */
  21
  22
  23 \f
  24
  25 #if HAVE_CONFIG_H
  26 #  include <config.h>
  27 #endif
  28
  29 #include "libguile/_scm.h"
  30 #ifdef HAVE_RL_GETC_FUNCTION
  31 #include "libguile.h"
  32 #include "libguile/gh.h"
  33 #include "libguile/iselect.h"
  34
  35 #include <stdio.h>
  36 #ifdef HAVE_UNISTD_H
  37 #include <unistd.h>
  38 #endif
  39 #include <readline/readline.h>
  40 #include <readline/history.h>
  41 #ifndef __MINGW32__
  42 #include <sys/time.h>
  43 #else
  44 #include <io.h>
  45 #endif
  46 #include <signal.h>
  47
  48 #include "libguile/validate.h"
  49 #include "guile-readline/readline.h"
  50
  51 scm_t_option scm_readline_opts[] = {
  52   { SCM_OPTION_BOOLEAN, "history-file", 1,
  53     "Use history file." },
  54   { SCM_OPTION_INTEGER, "history-length", 200,
  55     "History length." },
  56   { SCM_OPTION_INTEGER, "bounce-parens", 500,
  57     "Time (ms) to show matching opening parenthesis (0 = off)."}
  58 };
  59
  60 extern void stifle_history (int max);
  61
  62 SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
  63             (SCM setting),
  64 "")
  65 #define FUNC_NAME s_scm_readline_options
  66 {
  67   SCM ans = scm_options (setting,
  68                          scm_readline_opts,
  69                          SCM_N_READLINE_OPTIONS,
  70                          FUNC_NAME);
  71   stifle_history (SCM_HISTORY_LENGTH);
  72   return ans;
  73 }
  74 #undef FUNC_NAME
  75
  76 #ifndef HAVE_STRDUP
  77 static char *
  78 strdup (char *s)
  79 {
  80   size_t len = strlen (s);
  81   char *new = malloc (len + 1);
  82   strcpy (new, s);
  83   return new;
  84 }
  85 #endif /* HAVE_STRDUP */
  86
  87 #ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
  88
  89 /* These are readline functions added in release 2.3.  They will work
  90  * together with readline-2.1 and 2.2.  (The readline interface is
  91  * disabled for earlier releases.)
  92  * They are declared static; if we want to use them elsewhere, then
  93  * we need external declarations for them, but at the moment, I don't
  94  * think anything else in Guile ought to use these.
  95  */
  96
  97 extern void _rl_clean_up_for_exit ();
  98 extern void _rl_kill_kbd_macro ();
  99 extern int _rl_init_argument ();
 100
 101 void
 102 rl_cleanup_after_signal ()
 103 {
 104 #ifdef HAVE_RL_CLEAR_SIGNALS
 105   _rl_clean_up_for_exit ();
 106 #endif
 107   (*rl_deprep_term_function) ();
 108 #ifdef HAVE_RL_CLEAR_SIGNALS
 109   rl_clear_signals ();
 110 #endif
 111   rl_pending_input = 0;
 112 }
 113
 114 void
 115 rl_free_line_state ()
 116 {
 117   register HIST_ENTRY *entry;
 118
 119   free_undo_list ();
 120
 121   entry = current_history ();
 122   if (entry)
 123     entry->data = (char *)NULL;
 124
 125   _rl_kill_kbd_macro ();
 126   rl_clear_message ();
 127   _rl_init_argument ();
 128 }
 129
 130 #endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
 131
 132 static int promptp;
 133 static SCM input_port;
 134 static SCM before_read;
 135
 136 static int
 137 current_input_getc (FILE *in SCM_UNUSED)
 138 {
 139   if (promptp && scm_is_true (before_read))
 140     {
 141       scm_apply (before_read, SCM_EOL, SCM_EOL);
 142       promptp = 0;
 143     }
 144   return scm_getc (input_port);
 145 }
 146
 147 static int in_readline = 0;
 148 static SCM reentry_barrier_mutex;
 149
 150 static SCM internal_readline (SCM text);
 151 static SCM handle_error (void *data, SCM tag, SCM args);
 152 static void reentry_barrier (void);
 153
 154
 155 SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
 156             (SCM text, SCM inp, SCM outp, SCM read_hook),
 157 "")
 158 #define FUNC_NAME s_scm_readline
 159 {
 160   SCM ans;
 161
 162   reentry_barrier ();
 163
 164   before_read = SCM_BOOL_F;
 165
 166   if (!SCM_UNBNDP (text))
 167     {
 168       if (!SCM_STRINGP (text))
 169         {
 170           --in_readline;
 171           scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
 172         }
 173     }
 174
 175   if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_cur_inp))
 176         || SCM_OPINFPORTP (inp)))
 177     {
 178       --in_readline;
 179       scm_misc_error (s_scm_readline,
 180                       "Input port is not open or not a file port",
 181                       SCM_EOL);
 182     }
 183
 184   if (!((SCM_UNBNDP (outp) && SCM_OPOUTFPORTP (scm_cur_outp))
 185         || SCM_OPOUTFPORTP (outp)))
 186     {
 187       --in_readline;
 188       scm_misc_error (s_scm_readline,
 189                       "Output port is not open or not a file port",
 190                       SCM_EOL);
 191     }
 192
 193   if (!(SCM_UNBNDP (read_hook) || scm_is_false (read_hook)))
 194     {
 195       if (scm_is_false (scm_thunk_p (read_hook)))
 196         {
 197           --in_readline;
 198           scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
 199         }
 200       before_read = read_hook;
 201     }
 202
 203   scm_readline_init_ports (inp, outp);
 204
 205   ans = scm_internal_catch (SCM_BOOL_T,
 206                             (scm_t_catch_body) internal_readline,
 207                             (void *) SCM_UNPACK (text),
 208                             handle_error, 0);
 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 static SCM
 237 handle_error (void *data, SCM tag, SCM args)
 238 {
 239   rl_free_line_state ();
 240   rl_cleanup_after_signal ();
 241   fputc ('\n', rl_outstream); /* We don't want next output on this line */
 242 #ifndef __MINGW32__
 243   fclose (rl_instream);
 244   fclose (rl_outstream);
 245 #endif
 246   --in_readline;
 247   scm_handle_by_throw (data, tag, args);
 248   return SCM_UNSPECIFIED; /* never reached */
 249 }
 250
 251 static SCM
 252 internal_readline (SCM text)
 253 {
 254   SCM ret;
 255   char *s;
 256   char *prompt = SCM_UNBNDP (text) ? "" : SCM_STRING_CHARS (text);
 257
 258   promptp = 1;
 259   s = readline (prompt);
 260   if (s)
 261     ret = scm_makfrom0str (s);
 262   else
 263     ret = SCM_EOF_VAL;
 264
 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_cur_inp;
 298
 299   if (SCM_UNBNDP (outp))
 300     outp = scm_cur_outp;
 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   SCM_VALIDATE_STRING (1,text);
 330
 331   s = SCM_STRING_CHARS (text);
 332   add_history (strdup (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   SCM_VALIDATE_STRING (1,file);
 345   return scm_from_bool (!read_history (SCM_STRING_CHARS (file)));
 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   SCM_VALIDATE_STRING (1,file);
 356   return scm_from_bool (!write_history (SCM_STRING_CHARS (file)));
 357 }
 358 #undef FUNC_NAME
 359
 360 SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0,
 361             (),
 362             "Clear the history buffer of the readline machinery.")
 363 #define FUNC_NAME s_scm_clear_history
 364 {
 365   clear_history();
 366   return SCM_UNSPECIFIED;
 367 }
 368 #undef FUNC_NAME
 369
 370
 371 SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0,
 372             (SCM text, SCM continuep),
 373 "")
 374 #define FUNC_NAME s_scm_filename_completion_function
 375 {
 376   char *s;
 377   SCM ans;
 378   SCM_VALIDATE_STRING (1,text);
 379 #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
 380   s = rl_filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep));
 381 #else
 382   s = filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep));
 383 #endif
 384   ans = scm_makfrom0str (s);
 385   free (s);
 386   return ans;
 387 }
 388 #undef FUNC_NAME
 389
 390 /*
 391  * The following has been modified from code contributed by
 392  * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
 393  */
 394
 395 SCM scm_readline_completion_function_var;
 396
 397 static char *
 398 completion_function (char *text, int continuep)
 399 {
 400   SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var);
 401   SCM res;
 402
 403   if (scm_is_false (compfunc))
 404     return NULL; /* #f => completion disabled */
 405   else
 406     {
 407       SCM t = scm_makfrom0str (text);
 408       SCM c = scm_from_bool (continuep);
 409       res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
 410
 411       if (scm_is_false (res))
 412         return NULL;
 413
 414       if (!SCM_STRINGP (res))
 415         scm_misc_error (s_scm_readline,
 416                         "Completion function returned bogus value: %S",
 417                         scm_list_1 (res));
 418       return strdup (SCM_STRING_CHARS (res));
 419     }
 420 }
 421
 422 /*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/
 423
 424 static int match_paren (int x, int k);
 425 static int find_matching_paren (int k);
 426 static void init_bouncing_parens ();
 427
 428 static void
 429 init_bouncing_parens ()
 430 {
 431   if (strncmp (rl_get_keymap_name (rl_get_keymap ()), "vi", 2))
 432     {
 433       rl_bind_key (')', match_paren);
 434       rl_bind_key (']', match_paren);
 435       rl_bind_key ('}', match_paren);
 436     }
 437 }
 438
 439 static int
 440 find_matching_paren(int k)
 441 {
 442   register int i;
 443   register char c = 0;
 444   int end_parens_found = 0;
 445
 446   /* Choose the corresponding opening bracket.  */
 447   if (k == ')') c = '(';
 448   else if (k == ']') c = '[';
 449   else if (k == '}') c = '{';
 450
 451   for (i=rl_point-2; i>=0; i--)
 452     {
 453       /* Is the current character part of a character literal?  */
 454       if (i - 2 >= 0
 455           && rl_line_buffer[i - 1] == '\\'
 456           && rl_line_buffer[i - 2] == '#')
 457         ;
 458       else if (rl_line_buffer[i] == k)
 459         end_parens_found++;
 460       else if (rl_line_buffer[i] == '"')
 461         {
 462           /* Skip over a string literal.  */
 463           for (i--; i >= 0; i--)
 464             if (rl_line_buffer[i] == '"'
 465                 && ! (i - 1 >= 0
 466                       && rl_line_buffer[i - 1] == '\\'))
 467               break;
 468         }
 469       else if (rl_line_buffer[i] == c)
 470         {
 471           if (end_parens_found==0)
 472             return i;
 473           else --end_parens_found;
 474         }
 475     }
 476   return -1;
 477 }
 478
 479 static int
 480 match_paren (int x, int k)
 481 {
 482   int tmp;
 483 #ifndef __MINGW32__
 484   int fno;
 485   SELECT_TYPE readset;
 486   struct timeval timeout;
 487 #endif
 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 #ifndef __MINGW32__
 499   tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
 500   timeout.tv_sec = tmp / 1000000;
 501   timeout.tv_usec = tmp % 1000000;
 502   FD_ZERO (&readset);
 503   fno = fileno (rl_instream);
 504   FD_SET (fno, &readset);
 505 #endif
 506
 507   if (rl_point > 1)
 508     {
 509       tmp = rl_point;
 510       rl_point = find_matching_paren (k);
 511       if (rl_point > -1)
 512         {
 513           rl_redisplay ();
 514 #ifndef __MINGW32__
 515           scm_internal_select (fno + 1, &readset, NULL, NULL, &timeout);
 516 #else
 517           WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE),
 518                                SCM_READLINE_BOUNCE_PARENS);
 519 #endif
 520         }
 521       rl_point = tmp;
 522     }
 523   return 0;
 524 }
 525
 526 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 527 /* Readline disables SA_RESTART on SIGWINCH.
 528  * This code turns it back on.
 529  */
 530 static int
 531 sigwinch_enable_restart (void)
 532 {
 533 #ifdef HAVE_SIGINTERRUPT
 534   siginterrupt (SIGWINCH, 0);
 535 #else
 536   struct sigaction action;
 537
 538   sigaction (SIGWINCH, NULL, &action);
 539   action.sa_flags |= SA_RESTART;
 540   sigaction (SIGWINCH, &action, NULL);
 541 #endif
 542   return 0;
 543 }
 544 #endif
 545
 546 #endif /* HAVE_RL_GETC_FUNCTION */
 547
 548 void
 549 scm_init_readline ()
 550 {
 551 #ifdef HAVE_RL_GETC_FUNCTION
 552 #include "guile-readline/readline.x"
 553   scm_readline_completion_function_var
 554     = scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
 555 #ifndef __MINGW32__
 556   rl_getc_function = current_input_getc;
 557 #endif
 558 #if defined (_RL_FUNCTION_TYPEDEF)
 559   rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
 560 #else
 561   rl_completion_entry_function = (Function*) completion_function;
 562 #endif
 563   rl_basic_word_break_characters = "\t\n\"'`;()";
 564   rl_readline_name = "Guile";
 565 #if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED)
 566   rl_pre_input_hook = sigwinch_enable_restart;
 567 #endif
 568
 569   reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
 570   scm_init_opts (scm_readline_options,
 571                  scm_readline_opts,
 572                  SCM_N_READLINE_OPTIONS);
 573   init_bouncing_parens();
 574   scm_add_feature ("readline");
 575 #endif /* HAVE_RL_GETC_FUNCTION */
 576 }
 577
 578 /*
 579   Local Variables:
 580   c-file-style: "gnu"
 581   End:
 582 */