Codebase list libterm-readline-gnu-perl / debian/1.15-2
Fixing tag names Martín Ferrari 16 years ago
29 changed file(s) with 9851 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+588
-0
Gnu/XS.pm less more
0 #!/usr/local/bin/perl
1 #
2 # XS.pm : perl function definition for Term::ReadLine::Gnu
3 #
4 # $Id: XS.pm,v 1.22 2004-10-17 12:02:23-05 hiroo Exp $
5 #
6 # Copyright (c) 2003 Hiroo Hayashi. All rights reserved.
7 #
8 # This program is free software; you can redistribute it and/or
9 # modify it under the same terms as Perl itself.
10
11 package Term::ReadLine::Gnu::XS;
12
13 use Carp;
14 use strict;
15 use AutoLoader 'AUTOLOAD';
16
17 # make aliases
18 use vars qw(%Attribs);
19 *Attribs = \%Term::ReadLine::Gnu::Attribs;
20
21 use vars qw(*read_history);
22 *read_history = \&read_history_range;
23
24 # alias for 8 characters limitation imposed by AutoSplit
25 use vars qw(*rl_unbind_key *rl_unbind_function *rl_unbind_command
26 *history_list *history_arg_extract);
27 *rl_unbind_key = \&unbind_key;
28 *rl_unbind_function = \&unbind_function;
29 *rl_unbind_command = \&unbind_command;
30 *history_list = \&hist_list;
31 *history_arg_extract = \&hist_arg_extract;
32
33 # For backward compatibility. Using these name (*_in_map) is deprecated.
34 use vars qw(*rl_unbind_function_in_map *rl_unbind_command_in_map);
35 *rl_unbind_function_in_map = \&unbind_function;
36 *rl_unbind_command_in_map = \&unbind_command;
37
38 rl_add_defun('history-expand-line', \&history_expand_line);
39 # bind operate-and-get-next to \C-o by default for the compatibility
40 # with bash and Term::ReadLine::Perl
41 rl_add_defun('operate-and-get-next', \&operate_and_get_next, ord "\co");
42 rl_add_defun('display-readline-version', \&display_readline_version);
43 rl_add_defun('change-ornaments', \&change_ornaments);
44
45 # for ornaments()
46
47 # Prompt-start, prompt-end, command-line-start, command-line-end
48 # -- zero-width beautifies to emit around prompt and the command line.
49 # string encoded:
50 my $rl_term_set = ',,,';
51
52 # These variables are used by completion functions. Don't use for
53 # other purpose.
54 my $_i;
55 my @_matches;
56 my @_tstrs;
57 my $_tstrs_init = 0;
58
59 1;
60
61 # Uncomment the following line to enable AutoSplit. If you are using
62 # AutoLoader.pm distributed with Perl 5.004 or earlier, you must
63 # update AutoLoader.pm due to its bug.
64
65 #__END__
66
67
68 #
69 # Readline Library function wrappers
70 #
71
72 # Convert keymap name to Keymap if the argument is not reference to Keymap
73 sub _str2map ($) {
74 return ref $_[0] ? $_[0]
75 : (rl_get_keymap_by_name($_[0]) || carp "unknown keymap name \`$_[0]\'\n");
76 }
77
78 # Convert function name to Function if the argument is not reference
79 # to Function
80 sub _str2fn ($) {
81 return ref $_[0] ? $_[0]
82 : (rl_named_function($_[0]) || carp "unknown function name \`$_[0]\'\n");
83 }
84
85 sub rl_copy_keymap ($) { return _rl_copy_keymap(_str2map($_[0])); }
86 sub rl_discard_keymap ($) { return _rl_discard_keymap(_str2map($_[0])); }
87 sub rl_set_keymap ($) { return _rl_set_keymap(_str2map($_[0])); }
88
89 # rl_bind_key
90 sub rl_bind_key ($$;$) {
91 if (defined $_[2]) {
92 return _rl_bind_key($_[0], _str2fn($_[1]), _str2map($_[2]));
93 } else {
94 return _rl_bind_key($_[0], _str2fn($_[1]));
95 }
96 }
97
98 # rl_bind_key_if_unbound
99 sub rl_bind_key_if_unbound ($$;$) {
100 my ($version) = $Attribs{library_version}
101 =~ /(\d+\.\d+)/;
102 if ($version < 5.0) {
103 carp "rl_bind_key_if_unbound() is not supported. Ignored\n";
104 return;
105 }
106 if (defined $_[2]) {
107 return _rl_bind_key_if_unbound($_[0], _str2fn($_[1]), _str2map($_[2]));
108 } else {
109 return _rl_bind_key_if_unbound($_[0], _str2fn($_[1]));
110 }
111 }
112
113 # rl_unbind_key
114 sub unbind_key ($;$) {
115 if (defined $_[1]) {
116 return _rl_unbind_key($_[0], _str2map($_[1]));
117 } else {
118 return _rl_unbind_key($_[0]);
119 }
120 }
121
122 # rl_unbind_function
123 sub unbind_function ($;$) {
124 # libreadline.* in Debian GNU/Linux 2.0 tells wrong value as '2.1-bash'
125 my ($version) = $Attribs{library_version}
126 =~ /(\d+\.\d+)/;
127 if ($version < 2.2) {
128 carp "rl_unbind_function() is not supported. Ignored\n";
129 return;
130 }
131 if (defined $_[1]) {
132 return _rl_unbind_function($_[0], _str2map($_[1]));
133 } else {
134 return _rl_unbind_function($_[0]);
135 }
136 }
137
138 # rl_unbind_command
139 sub unbind_command ($;$) {
140 my ($version) = $Attribs{library_version}
141 =~ /(\d+\.\d+)/;
142 if ($version < 2.2) {
143 carp "rl_unbind_command() is not supported. Ignored\n";
144 return;
145 }
146 if (defined $_[1]) {
147 return _rl_unbind_command($_[0], _str2map($_[1]));
148 } else {
149 return _rl_unbind_command($_[0]);
150 }
151 }
152
153 # rl_bind_keyseq
154 sub rl_bind_keyseq ($$;$) {
155 my ($version) = $Attribs{library_version}
156 =~ /(\d+\.\d+)/;
157 if ($version < 5.0) {
158 carp "rl_bind_keyseq() is not supported. Ignored\n";
159 return;
160 }
161 if (defined $_[2]) {
162 return _rl_bind_keyseq($_[0], _str2fn($_[1]), _str2map($_[2]));
163 } else {
164 return _rl_bind_keyseq($_[0], _str2fn($_[1]));
165 }
166 }
167
168 sub rl_set_key ($$;$) {
169 my ($version) = $Attribs{library_version}
170 =~ /(\d+\.\d+)/;
171 if ($version < 4.2) {
172 carp "rl_set_key() is not supported. Ignored\n";
173 return;
174 }
175 if (defined $_[2]) {
176 return _rl_set_key($_[0], _str2fn($_[1]), _str2map($_[2]));
177 } else {
178 return _rl_set_key($_[0], _str2fn($_[1]));
179 }
180 }
181
182 # rl_bind_keyseq_if_unbound
183 sub rl_bind_keyseq_if_unbound ($$;$) {
184 my ($version) = $Attribs{library_version}
185 =~ /(\d+\.\d+)/;
186 if ($version < 5.0) {
187 carp "rl_bind_keyseq_if_unbound() is not supported. Ignored\n";
188 return;
189 }
190 if (defined $_[2]) {
191 return _rl_bind_keyseq_if_unbound($_[0], _str2fn($_[1]), _str2map($_[2]));
192 } else {
193 return _rl_bind_keyseq_if_unbound($_[0], _str2fn($_[1]));
194 }
195 }
196
197 sub rl_macro_bind ($$;$) {
198 my ($version) = $Attribs{library_version}
199 =~ /(\d+\.\d+)/;
200 if (defined $_[2]) {
201 return _rl_macro_bind($_[0], $_[1], _str2map($_[2]));
202 } else {
203 return _rl_macro_bind($_[0], $_[1]);
204 }
205 }
206
207 sub rl_generic_bind ($$$;$) {
208 if ($_[0] == Term::ReadLine::Gnu::ISFUNC) {
209 if (defined $_[3]) {
210 _rl_generic_bind_function($_[1], _str2fn($_[2]), _str2map($_[3]));
211 } else {
212 _rl_generic_bind_function($_[1], _str2fn($_[2]));
213 }
214 } elsif ($_[0] == Term::ReadLine::Gnu::ISKMAP) {
215 if (defined $_[3]) {
216 _rl_generic_bind_keymap($_[1], _str2map($_[2]), _str2map($_[3]));
217 } else {
218 _rl_generic_bind_keymap($_[1], _str2map($_[2]));
219 }
220 } elsif ($_[0] == Term::ReadLine::Gnu::ISMACR) {
221 if (defined $_[3]) {
222 _rl_generic_bind_macro($_[1], $_[2], _str2map($_[3]));
223 } else {
224 _rl_generic_bind_macro($_[1], $_[2]);
225 }
226 } else {
227 carp("Term::ReadLine::Gnu::rl_generic_bind: invalid \`type\'\n");
228 }
229 }
230
231 sub rl_call_function ($;$$) {
232 if (defined $_[2]) {
233 return _rl_call_function(_str2fn($_[0]), $_[1], $_[2]);
234 } elsif (defined $_[1]) {
235 return _rl_call_function(_str2fn($_[0]), $_[1]);
236 } else {
237 return _rl_call_function(_str2fn($_[0]));
238 }
239 }
240
241 sub rl_invoking_keyseqs ($;$) {
242 if (defined $_[1]) {
243 return _rl_invoking_keyseqs(_str2fn($_[0]), _str2map($_[1]));
244 } else {
245 return _rl_invoking_keyseqs(_str2fn($_[0]));
246 }
247 }
248
249 sub rl_add_funmap_entry ($$) {
250 my ($version) = $Attribs{library_version}
251 =~ /(\d+\.\d+)/;
252 if ($version < 4.2) {
253 carp "rl_add_funmap_entry() is not supported. Ignored\n";
254 return;
255 }
256 return _rl_add_funmap_entry($_[0], _str2fn($_[1]));
257 }
258
259 sub rl_tty_set_default_bindings (;$) {
260 my ($version) = $Attribs{library_version}
261 =~ /(\d+\.\d+)/;
262 if ($version < 4.2) {
263 carp "rl_tty_set_default_bindings() is not supported. Ignored\n";
264 return;
265 }
266 if (defined $_[0]) {
267 return _rl_tty_set_defaut_bindings(_str2map($_[1]));
268 } else {
269 return _rl_tty_set_defaut_bindings();
270 }
271 }
272
273 sub rl_tty_unset_default_bindings (;$) {
274 my ($version) = $Attribs{library_version}
275 =~ /(\d+\.\d+)/;
276 if ($version < 5.0) {
277 carp "rl_tty_unset_default_bindings() is not supported. Ignored\n";
278 return;
279 }
280 if (defined $_[0]) {
281 return _rl_tty_unset_defaut_bindings(_str2map($_[1]));
282 } else {
283 return _rl_tty_unset_defaut_bindings();
284 }
285 }
286
287 sub rl_message {
288 my $fmt = shift;
289 my $line = sprintf($fmt, @_);
290 _rl_message($line);
291 }
292
293 sub rl_completion_mode {
294 # libreadline.* in Debian GNU/Linux 2.0 tells wrong value as '2.1-bash'
295 my ($version) = $Attribs{library_version}
296 =~ /(\d+\.\d+)/;
297 if ($version < 4.3) {
298 carp "rl_completion_mode() is not supported. Ignored\n";
299 return;
300 }
301 return _rl_completion_mode(_str2fn($_[0]));
302 }
303
304 #
305 # for compatibility with Term::ReadLine::Perl
306 #
307 sub rl_filename_list {
308 my ($text) = @_;
309
310 # lcd : lowest common denominator
311 my ($lcd, @matches) = rl_completion_matches($text,
312 \&rl_filename_completion_function);
313 return @matches ? @matches : $lcd;
314 }
315
316 #
317 # History Library function wrappers
318 #
319 # history_list
320 sub hist_list () {
321 my ($i, $history_base, $history_length, @d);
322 $history_base = $Attribs{history_base};
323 $history_length = $Attribs{history_length};
324 for ($i = $history_base; $i < $history_base + $history_length; $i++) {
325 push(@d, history_get($i));
326 }
327 @d;
328 }
329
330 # history_arg_extract
331 sub hist_arg_extract ( ;$$$ ) {
332 my ($line, $first, $last) = @_;
333 $line = $_ unless defined $line;
334 $first = 0 unless defined $first;
335 $last = ord '$' unless defined $last; # '
336 $first = ord '$' if defined $first and $first eq '$'; # '
337 $last = ord '$' if defined $last and $last eq '$'; # '
338 &_history_arg_extract($line, $first, $last);
339 }
340
341 sub get_history_event ( $$;$ ) {
342 _get_history_event($_[0], $_[1], defined $_[2] ? ord $_[2] : 0);
343 }
344
345 #
346 # Ornaments
347 #
348
349 # This routine originates in Term::ReadLine.pm.
350
351 # Debian GNU/Linux discourages users from using /etc/termcap. A
352 # subroutine ornaments() defined in Term::ReadLine.pm uses
353 # Term::Caps.pm which requires /etc/termcap.
354
355 # This module calls termcap (or its compatible) library, which the GNU
356 # Readline Library already uses, instead of Term::Caps.pm.
357
358 # Some terminals do not support 'ue' (underline end).
359 use vars qw(%term_no_ue);
360 %term_no_ue = ( kterm => 1 );
361
362
363 sub ornaments {
364 return $rl_term_set unless @_;
365 $rl_term_set = shift;
366 $rl_term_set ||= ',,,';
367 $rl_term_set = $term_no_ue{defined($ENV{TERM}) ? $ENV{TERM} : ''} ? 'us,me,,' : 'us,ue,,'
368 if $rl_term_set eq '1';
369 my @ts = split /,/, $rl_term_set, 4;
370 my @rl_term_set
371 = map {
372 # non-printing characters must be informed to readline
373 my $t;
374 ($_ and $t = tgetstr($_))
375 ? (Term::ReadLine::Gnu::RL_PROMPT_START_IGNORE
376 . $t
377 . Term::ReadLine::Gnu::RL_PROMPT_END_IGNORE)
378 : '';
379 } @ts;
380 $Attribs{term_set} = \@rl_term_set;
381 return $rl_term_set;
382 }
383
384 #
385 # a sample custom function
386 #
387
388 # The equivalent of the Bash shell M-^ history-expand-line editing
389 # command.
390
391 # This routine was borrowed from bash.
392 sub history_expand_line {
393 my ($count, $key) = @_;
394 my ($expanded, $new_line) = history_expand($Attribs{line_buffer});
395 if ($expanded > 0) {
396 rl_modifying(0, $Attribs{end}); # save undo information
397 $Attribs{line_buffer} = $new_line;
398 } elsif ($expanded < 0) {
399 my $OUT = $Attribs{outstream};
400 print $OUT "\n$new_line\n";
401 rl_on_new_line();
402 } # $expanded == 0 : no change
403 }
404
405 # The equivalent of the Korn shell C-o operate-and-get-next-history-line
406 # editing command.
407
408 # This routine was borrowed from bash.
409 sub operate_and_get_next {
410 my ($count, $key) = @_;
411
412 my $saved_history_line_to_use = -1;
413 my $old_rl_startup_hook;
414
415 # Accept the current line.
416 rl_call_function('accept-line', 1, $key);
417
418 # Find the current line, and find the next line to use. */
419 my $where = where_history();
420 if ((history_is_stifled()
421 && ($Attribs{history_length} >= $Attribs{max_input_history}))
422 || ($where >= $Attribs{history_length} - 1)) {
423 $saved_history_line_to_use = $where;
424 } else {
425 $saved_history_line_to_use = $where + 1;
426 }
427 $old_rl_startup_hook = $Attribs{startup_hook};
428 $Attribs{startup_hook} = sub {
429 if ($saved_history_line_to_use >= 0) {
430 rl_call_function('previous-history',
431 $Attribs{history_length}
432 - $saved_history_line_to_use,
433 0);
434 $Attribs{startup_hook} = $old_rl_startup_hook;
435 $saved_history_line_to_use = -1;
436 }
437 };
438 }
439
440 sub display_readline_version { # show version
441 my($count, $key) = @_; # ignored in this function
442 my $OUT = $Attribs{outstream};
443 print $OUT
444 ("\nTerm::ReadLine::Gnu version: $Term::ReadLine::Gnu::VERSION");
445 print $OUT
446 ("\nGNU Readline Library version: $Attribs{library_version}\n");
447 rl_on_new_line();
448 }
449
450 # sample function of rl_message()
451 sub change_ornaments {
452 my($count, $key) = @_; # ignored in this function
453 rl_save_prompt;
454 rl_message("[S]tandout, [U]nderlining, [B]old, [R]everse, [V]isible bell: ");
455 my $c = chr rl_read_key;
456 if ($c =~ /s/i) {
457 ornaments('so,me,,');
458 } elsif ($c =~ /u/i) {
459 ornaments('us,me,,');
460 } elsif ($c =~ /b/i) {
461 ornaments('md,me,,');
462 } elsif ($c =~ /r/i) {
463 ornaments('mr,me,,');
464 } elsif ($c =~ /v/i) {
465 ornaments('vb,,,');
466 } else {
467 rl_ding;
468 }
469 rl_restore_prompt;
470 rl_clear_message;
471 }
472
473 #
474 # for tkRunning
475 #
476 sub Tk_getc {
477 &Term::ReadLine::Tk::Tk_loop
478 if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
479 my $FILE = $Attribs{instream};
480 return rl_getc($FILE);
481 }
482
483 # redisplay function for secret input like password
484 # usage:
485 # $a->{redisplay_function} = $a->{shadow_redisplay};
486 # $line = $t->readline("password> ");
487 sub shadow_redisplay {
488 @_tstrs = _tgetstrs() unless $_tstrs_init;
489 # remove prompt start/end mark from prompt string
490 my $prompt = $Attribs{prompt}; my $s;
491 $s = Term::ReadLine::Gnu::RL_PROMPT_START_IGNORE; $prompt =~ s/$s//g;
492 $s = Term::ReadLine::Gnu::RL_PROMPT_END_IGNORE; $prompt =~ s/$s//g;
493 my $OUT = $Attribs{outstream};
494 my $oldfh = select($OUT); $| = 1; select($oldfh);
495 print $OUT ($_tstrs[0], # carriage return
496 $_tstrs[1], # clear to EOL
497 $prompt, '*' x length($Attribs{line_buffer}));
498 print $OUT ($_tstrs[2] # cursor left
499 x (length($Attribs{line_buffer}) - $Attribs{point}));
500 $oldfh = select($OUT); $| = 0; select($oldfh);
501 }
502
503 sub _tgetstrs {
504 my @s = (tgetstr('cr'), # carriage return
505 tgetstr('ce'), # clear to EOL
506 tgetstr('le')); # cursor left
507 warn <<"EOM" unless (defined($s[0]) && defined($s[1]) && defined($s[2]));
508 Your terminal 'TERM=$ENV{TERM}' does not support enough function.
509 Check if your environment variable 'TERM' is set correctly.
510 EOM
511 # suppress warning "Use of uninitialized value in print at ..."
512 $s[0] = $s[0] || ''; $s[1] = $s[1] || ''; $s[2] = $s[2] || '';
513 $_tstrs_init = 1;
514 return @s;
515 }
516
517 # callback handler wrapper function for CallbackHandlerInstall method
518 sub _ch_wrapper {
519 my $line = shift;
520
521 if (defined $line) {
522 if ($Attribs{do_expand}) {
523 my $result;
524 ($result, $line) = history_expand($line);
525 my $outstream = $Attribs{outstream};
526 print $outstream "$line\n" if ($result);
527
528 # return without adding line into history
529 if ($result < 0 || $result == 2) {
530 return ''; # don't return `undef' which means EOF.
531 }
532 }
533
534 # add to history buffer
535 add_history($line)
536 if ($Attribs{MinLength} > 0
537 && length($line) >= $Attribs{MinLength});
538 }
539 &{$Attribs{_callback_handler}}($line);
540 }
541
542 #
543 # List Completion Function
544 #
545 sub list_completion_function ( $$ ) {
546 my($text, $state) = @_;
547
548 $_i = $state ? $_i + 1 : 0; # clear counter at the first call
549 my $cw = $Attribs{completion_word};
550 for (; $_i <= $#{$cw}; $_i++) {
551 return $cw->[$_i] if ($cw->[$_i] =~ /^\Q$text/);
552 }
553 return undef;
554 }
555
556 #
557 # wrapper completion function of 'completion_function'
558 # for compatibility with Term::ReadLine::Perl
559 #
560 sub _trp_completion_function ( $$ ) {
561 my($text, $state) = @_;
562
563 my $cf;
564 return undef unless defined ($cf = $Attribs{completion_function});
565
566 if ($state) {
567 $_i++;
568 } else {
569 # the first call
570 $_i = 0; # clear index
571 @_matches = &$cf($text,
572 $Attribs{line_buffer},
573 $Attribs{point} - length($text));
574 # return here since $#_matches is 0 instead of -1 when
575 # @_matches = undef
576 return undef unless defined $_matches[0];
577 }
578
579 for (; $_i <= $#_matches; $_i++) {
580 return $_matches[$_i] if ($_matches[$_i] =~ /^\Q$text/);
581 }
582 return undef;
583 }
584
585 1;
586
587 __END__
+187
-0
Gnu/euc_jp.pm less more
0 #!/usr/local/bin/perl
1 #
2 # euc_jp.pm : EUC Japanese Character Support Functions
3 # This modules is experimental. API may be changed.
4 #
5 # $Id: euc_jp.pm,v 1.2 2001-04-22 22:35:41+09 hayashi Exp $
6 #
7 # Copyright (c) 2001 Hiroo Hayashi. All rights reserved.
8 #
9 # This program is free software; you can redistribute it and/or
10 # modify it under the same terms as Perl itself.
11 #
12
13 package Term::ReadLine::Gnu::XS;
14
15 use Carp;
16 use strict;
17
18 # make aliases
19 use vars qw(%Attribs);
20 *Attribs = \%Term::ReadLine::Gnu::Attribs;
21
22 # enable Meta
23 rl_prep_terminal(1);
24
25 rl_add_defun('euc-jp-forward', \&ej_forward);
26 rl_add_defun('euc-jp-backward', \&ej_backward);
27 rl_add_defun('euc-jp-backward-delete-char', \&ej_rubout);
28 rl_add_defun('euc-jp-delete-char', \&ej_delete);
29 rl_add_defun('euc-jp-forward-backward-delete-char', \&ej_rubout_or_delete);
30 rl_add_defun('euc-jp-transpose-chars', \&ej_transpose_chars);
31
32 rl_bind_key(ord "\cf", 'euc-jp-forward');
33 rl_bind_key(ord "\cb", 'euc-jp-backward');
34 rl_bind_key(ord "\ch", 'euc-jp-backward-delete-char');
35 #rl_bind_key(ord "\cd", 'euc-jp-delete-char');
36 rl_bind_key(ord "\cd", 'euc-jp-forward-backward-delete-char');
37 rl_bind_key(ord "\ct", 'euc-jp-transpose-chars');
38
39 1;
40
41 # An EUC Japanese character consists of two 8 bit characters.
42 # And the MSBs (most significant bit) of both bytes are set.
43
44 # To support Shift-JIS charactor set the following two functions
45 # must be extended.
46 sub ej_first_byte_p {
47 my ($p) = @_;
48 my $l = $Attribs{line_buffer};
49 return substr($l, $p, 1) =~ /[\x80-\xff]/
50 && substr($l, 0, $p) =~ /^([\x00-x7f]|([\x80-\xff][\x80-\xff]))*$/;
51 }
52
53 sub ej_second_byte_p {
54 my ($p) = @_;
55 my $l = $Attribs{line_buffer};
56 return $p > 0 && substr($l, $p, 1) =~ /[\x80-\xff]/
57 && substr($l, 0, $p) !~ /^([\x00-x7f]|([\x80-\xff][\x80-\xff]))*$/;
58 }
59
60 #forward-char
61 sub ej_forward {
62 my($count, $key) = @_;
63 if ($count < 0) {
64 ej_backward(-$count, $key);
65 } else {
66 while ($count--) {
67 if (ej_first_byte_p($Attribs{point})) {
68 rl_call_function('forward-char', 2, $key);
69 } else {
70 rl_call_function('forward-char', 1, $key);
71 }
72 }
73 }
74 return 0;
75 }
76
77 #backward-char
78 sub ej_backward {
79 my($count, $key) = @_;
80 if ($count < 0) {
81 ej_forward(-$count, $key);
82 } else {
83 while ($count--) {
84 if (ej_second_byte_p($Attribs{point})) {
85 rl_call_function('backward-char', 1, $key);
86 }
87 if (ej_second_byte_p($Attribs{point} - 1)) {
88 rl_call_function('backward-char', 2, $key);
89 } else {
90 rl_call_function('backward-char', 1, $key);
91 }
92 }
93 }
94 return 0;
95 }
96
97 #backward-delete-char
98 sub ej_rubout {
99 my($count, $key) = @_;
100 if ($count < 0) {
101 ej_delete(-$count, $key);
102 } else {
103 if ($Attribs{point} <= 0) {
104 rl_ding();
105 return 1;
106 }
107 while ($count--) {
108 if (ej_second_byte_p($Attribs{point})) {
109 $Attribs{point}--;
110 }
111 if (ej_second_byte_p($Attribs{point} - 1)) {
112 rl_call_function('backward-delete-char', 2, $key);
113 } else {
114 rl_call_function('backward-delete-char', 1, $key);
115 }
116 }
117 }
118 return 0;
119 }
120
121 #delete-char
122 sub ej_delete {
123 my($count, $key) = @_;
124 if ($count < 0) {
125 ej_rubout(-$count, $key);
126 } else {
127 while ($count--) {
128 if (ej_first_byte_p($Attribs{point})) {
129 rl_call_function('delete-char', 2, $key);
130 } elsif (ej_second_byte_p($Attribs{point})) {
131 rl_call_function('backward-delete-char', 1, $key);
132 rl_call_function('delete-char', 1, $key);
133 } else {
134 rl_call_function('delete-char', 1, $key);
135 }
136 }
137 }
138 return 0;
139 }
140
141 #forward-backward-delete-char
142 sub ej_rubout_or_delete {
143 my($count, $key) = @_;
144 if ($Attribs{end} != 0 && $Attribs{point} == $Attribs{end}) {
145 return ej_rubout($count, $key);
146 } else {
147 return ej_delete($count, $key);
148 }
149 }
150
151 #transpose-chars
152 sub ej_transpose_chars {
153 my($count, $key) = @_;
154
155 return 0 unless $count;
156
157 if (ej_second_byte_p($Attribs{point})) {
158 $Attribs{point}--;
159 }
160 if ($Attribs{point} == 0 # the beginning of the line
161 || ($Attribs{end} < 2) # only one ascii char
162 # only one EUC char
163 || ($Attribs{end} == 2 && ej_first_byte_p(0))) {
164 rl_ding();
165 return -1;
166 }
167 rl_begin_undo_group();
168 if ($Attribs{point} == $Attribs{end}) {
169 # If point is at the end of the line
170 ej_backward(1, $key);
171 $count = 1;
172 }
173 ej_backward(1, $key);
174 my $dummy;
175 if (ej_first_byte_p($Attribs{point})) {
176 $dummy = substr($Attribs{line_buffer}, $Attribs{point}, 2);
177 rl_delete_text($Attribs{point}, $Attribs{point} + 2);
178 } else {
179 $dummy = substr($Attribs{line_buffer}, $Attribs{point}, 1);
180 rl_delete_text($Attribs{point}, $Attribs{point} + 1);
181 }
182 ej_forward($count, $key);
183 rl_insert_text($dummy);
184 rl_end_undo_group();
185 return 0;
186 }
+1912
-0
Gnu.pm less more
0 #
1 # Gnu.pm --- The GNU Readline/History Library wrapper module
2 #
3 # $Id: Gnu.pm,v 1.95 2004-10-17 12:44:43-05 hiroo Exp $
4 #
5 # Copyright (c) 2004 Hiroo Hayashi. All rights reserved.
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the same terms as Perl itself.
9 #
10 # Some of documentation strings in this file are cited from the
11 # GNU Readline/History Library Manual.
12
13 package Term::ReadLine::Gnu;
14
15 =head1 NAME
16
17 Term::ReadLine::Gnu - Perl extension for the GNU Readline/History Library
18
19 =head1 SYNOPSIS
20
21 use Term::ReadLine;
22 $term = new Term::ReadLine 'ProgramName';
23 while ( defined ($_ = $term->readline('prompt>')) ) {
24 ...
25 }
26
27 =head1 DESCRIPTION
28
29 =head2 Overview
30
31 This is an implementation of Term::ReadLine using the GNU
32 Readline/History Library.
33
34 For basic functions object oriented interface is provided. These are
35 described in the section L<"Standard Methods"|"Standard Methods"> and
36 L<"C<Term::ReadLine::Gnu> Functions"|"C<Term::ReadLine::Gnu> Functions">.
37
38 This package also has the interface with the almost all functions and
39 variables which are documented in the GNU Readline/History Library
40 Manual. They are documented in the section
41 L<"C<Term::ReadLine::Gnu> Functions"|"C<Term::ReadLine::Gnu> Functions">
42 and
43 L<"C<Term::ReadLine::Gnu> Variables"|"C<Term::ReadLine::Gnu> Variables">
44 briefly. For more detail of the GNU Readline/History Library, see
45 'GNU Readline Library Manual' and 'GNU History Library Manual'.
46
47 The sample programs under C<eg/> directory and test programs under
48 C<t/> directory in the C<Term::ReadLine::Gnu> distribution include
49 many example of this module.
50
51 =head2 Standard Methods
52
53 These methods are standard methods defined by B<Term::ReadLine>.
54
55 =cut
56
57 use strict;
58 use Carp;
59
60 # This module can't be loaded directly.
61 BEGIN {
62 if (not defined $Term::ReadLine::VERSION) {
63 croak <<END;
64 It is invalid to load Term::ReadLine::Gnu directly. Please consult
65 the Term::ReadLine documentation for more information.
66 END
67 }
68 }
69
70 {
71 use Exporter ();
72 use DynaLoader;
73 use vars qw($VERSION @ISA @EXPORT_OK);
74
75 $VERSION = '1.15';
76
77 # Term::ReadLine::Gnu::AU makes a function in
78 # `Term::ReadLine::Gnu::XS' as a method.
79 # The namespace of Term::ReadLine::Gnu::AU is searched before ones
80 # of other classes
81 @ISA = qw(Term::ReadLine::Gnu::AU Term::ReadLine::Stub
82 Exporter DynaLoader);
83
84 @EXPORT_OK = qw(RL_PROMPT_START_IGNORE RL_PROMPT_END_IGNORE
85 NO_MATCH SINGLE_MATCH MULT_MATCH
86 ISFUNC ISKMAP ISMACR
87 UNDO_DELETE UNDO_INSERT UNDO_BEGIN UNDO_END
88 RL_STATE_NONE RL_STATE_INITIALIZING
89 RL_STATE_INITIALIZED RL_STATE_TERMPREPPED
90 RL_STATE_READCMD RL_STATE_METANEXT
91 RL_STATE_DISPATCHING RL_STATE_MOREINPUT
92 RL_STATE_ISEARCH RL_STATE_NSEARCH
93 RL_STATE_SEARCH RL_STATE_NUMERICARG
94 RL_STATE_MACROINPUT RL_STATE_MACRODEF
95 RL_STATE_OVERWRITE RL_STATE_COMPLETING
96 RL_STATE_SIGHANDLER RL_STATE_UNDOING
97 RL_STATE_DONE);
98
99 bootstrap Term::ReadLine::Gnu $VERSION; # DynaLoader
100 }
101 require Term::ReadLine::Gnu::XS;
102
103 # Global Variables
104
105 use vars qw(%Attribs %Features);
106
107 # Each variable in the GNU Readline Library is tied to an entry of
108 # this hash (%Attribs). By accessing the hash entry, you can read
109 # and/or write the variable in the GNU Readline Library. See the
110 # package definition of Term::ReadLine::Gnu::Var and following code
111 # for more details.
112
113 # Normal (non-tied) entries
114 %Attribs = (
115 MinLength => 1,
116 do_expand => 0,
117 completion_word => [],
118 term_set => ['', '', '', ''],
119 );
120 %Features = (
121 appname => 1, minline => 1, autohistory => 1,
122 getHistory => 1, setHistory => 1, addHistory => 1,
123 readHistory => 1, writeHistory => 1,
124 preput => 1, attribs => 1, newTTY => 1,
125 tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
126 ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
127 stiflehistory => 1,
128 );
129
130 sub Attribs { \%Attribs; }
131 sub Features { \%Features; }
132
133 #
134 # GNU Readline/History Library constant definition
135 # These are included in @EXPORT_OK.
136
137 # I can define these variables in XS code to use the value defined in
138 # readline.h, etc. But it needs some calling convention change and
139 # will cause compatiblity problem. I hope the definition of these
140 # constant value will not be changed.
141
142 # for non-printing characters in prompt string
143 sub RL_PROMPT_START_IGNORE { "\001"; }
144 sub RL_PROMPT_END_IGNORE { "\002"; }
145
146 # for rl_filename_quoting_function
147 sub NO_MATCH { 0; }
148 sub SINGLE_MATCH { 1; }
149 sub MULT_MATCH { 2; }
150
151 # for rl_generic_bind, rl_function_of_keyseq
152 sub ISFUNC { 0; }
153 sub ISKMAP { 1; }
154 sub ISMACR { 2; }
155
156 # for rl_add_undo
157 sub UNDO_DELETE { 0; }
158 sub UNDO_INSERT { 1; }
159 sub UNDO_BEGIN { 2; }
160 sub UNDO_END { 3; }
161
162 # for rl_readline_state
163 sub RL_STATE_NONE { 0x00000; } # no state; before first call
164 sub RL_STATE_INITIALIZING { 0x00001; } # initializing
165 sub RL_STATE_INITIALIZED { 0x00002; } # initialization done
166 sub RL_STATE_TERMPREPPED { 0x00004; } # terminal is prepped
167 sub RL_STATE_READCMD { 0x00008; } # reading a command key
168 sub RL_STATE_METANEXT { 0x00010; } # reading input after ESC
169 sub RL_STATE_DISPATCHING { 0x00020; } # dispatching to a command
170 sub RL_STATE_MOREINPUT { 0x00040; } # reading more input in a command function
171 sub RL_STATE_ISEARCH { 0x00080; } # doing incremental search
172 sub RL_STATE_NSEARCH { 0x00100; } # doing non-inc search
173 sub RL_STATE_SEARCH { 0x00200; } # doing a history search
174 sub RL_STATE_NUMERICARG { 0x00400; } # reading numeric argument
175 sub RL_STATE_MACROINPUT { 0x00800; } # getting input from a macro
176 sub RL_STATE_MACRODEF { 0x01000; } # defining keyboard macro
177 sub RL_STATE_OVERWRITE { 0x02000; } # overwrite mode
178 sub RL_STATE_COMPLETING { 0x04000; } # doing completion
179 sub RL_STATE_SIGHANDLER { 0x08000; } # in readline sighandler
180 sub RL_STATE_UNDOING { 0x10000; } # doing an undo
181 sub RL_STATE_DONE { 0x80000; } # done; accepted line
182
183 #
184 # Methods Definition
185 #
186
187 =over 4
188
189 =item C<ReadLine>
190
191 returns the actual package that executes the commands. If you have
192 installed this package, possible value is C<Term::ReadLine::Gnu>.
193
194 =cut
195
196 sub ReadLine { 'Term::ReadLine::Gnu'; }
197
198 =item C<new(NAME,[IN,OUT])>
199
200 returns the handle for subsequent calls to following functions.
201 Argument is the name of the application. Optionally can be followed
202 by two arguments for C<IN> and C<OUT> file handles. These arguments
203 should be globs.
204
205 =cut
206
207 # The origin of this function is Term::ReadLine::Perl.pm by Ilya Zakharevich.
208 sub new {
209 my $this = shift; # Package
210 my $class = ref($this) || $this;
211
212 croak "Wrong number of arguments" unless @_==1 or @_==3;
213 my $name = shift;
214
215 my $self = \%Attribs;
216 bless $self, $class;
217
218 # set rl_readline_name before .inputrc is read in rl_initialize()
219 $Attribs{readline_name} = $name;
220
221 # some version of Perl cause segmentation fault, if XS module
222 # calls setenv() before the 1st assignment to $ENV{}.
223 $ENV{_TRL_DUMMY} = '';
224
225 # initialize the GNU Readline Library and termcap library
226 $self->initialize();
227
228 # enable ornaments to be compatible with perl5.004_05(?)
229 unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) {
230 local $^W = 0; # Term::ReadLine is not warning flag free
231 # Without the next line Term::ReadLine::Stub::ornaments is used.
232 # Why does Term::ReadLine::Gnu::AU selects it at first?!!!
233 # If you know why this happens, please let me know. Thanks.
234 undef &Term::ReadLine::Gnu::ornaments;
235 $self->ornaments(1);
236 }
237
238 if (!@_) {
239 my ($IN,$OUT) = $self->findConsole();
240 open(IN,"<$IN") || croak "Cannot open $IN for read";
241 open(OUT,">$OUT") || croak "Cannot open $OUT for write";
242 # borrowed from Term/ReadLine.pm
243 my $sel = select(OUT);
244 $| = 1; # for DB::OUT
245 select($sel);
246 $Attribs{instream} = \*IN;
247 $Attribs{outstream} = \*OUT;
248 } else {
249 $Attribs{instream} = shift;
250 $Attribs{outstream} = shift;
251 }
252
253 $self;
254 }
255
256 sub DESTROY {}
257
258 =item C<readline(PROMPT[,PREPUT])>
259
260 gets an input line, with actual C<GNU Readline> support. Trailing
261 newline is removed. Returns C<undef> on C<EOF>. C<PREPUT> is an
262 optional argument meaning the initial value of input.
263
264 The optional argument C<PREPUT> is granted only if the value C<preput>
265 is in C<Features>.
266
267 C<PROMPT> may include some escape sequences. Use
268 C<RL_PROMPT_START_IGNORE> to begin a sequence of non-printing
269 characters, and C<RL_PROMPT_END_IGNORE> to end of such a sequence.
270
271 =cut
272
273 # to peacify -w
274 $Term::ReadLine::registered = $Term::ReadLine::registered;
275
276 sub readline { # should be ReadLine
277 my $self = shift;
278 my ($prompt, $preput) = @_;
279
280 # ornament support (now prompt only)
281 $prompt = ${$Attribs{term_set}}[0] . $prompt . ${$Attribs{term_set}}[1];
282
283 # `completion_function' support for compatibility with
284 # Term:ReadLine::Perl. Prefer $completion_entry_function, since a
285 # program which uses $completion_entry_function should know
286 # Term::ReadLine::Gnu and have better completion function using
287 # the variable.
288 $Attribs{completion_entry_function} = $Attribs{_trp_completion_function}
289 if (!defined $Attribs{completion_entry_function}
290 && defined $Attribs{completion_function});
291
292 # TkRunning support
293 if (not $Term::ReadLine::registered and $Term::ReadLine::toloop
294 and defined &Tk::DoOneEvent) {
295 $self->register_Tk;
296 $Attribs{getc_function} = $Attribs{Tk_getc};
297 }
298
299 # call readline()
300 my $line;
301 if (defined $preput) {
302 my $saved_startup_hook = $Attribs{startup_hook};
303 $Attribs{startup_hook} = sub {
304 $self->rl_insert_text($preput);
305 &$saved_startup_hook
306 if defined $saved_startup_hook;
307 };
308 $line = $self->rl_readline($prompt);
309 $Attribs{startup_hook} = $saved_startup_hook;
310 } else {
311 $line = $self->rl_readline($prompt);
312 }
313 return undef unless defined $line;
314
315 # history expansion
316 if ($Attribs{do_expand}) {
317 my $result;
318 ($result, $line) = $self->history_expand($line);
319 my $outstream = $Attribs{outstream};
320 print $outstream "$line\n" if ($result);
321
322 # return without adding line into history
323 if ($result < 0 || $result == 2) {
324 return ''; # don't return `undef' which means EOF.
325 }
326 }
327
328 # add to history buffer
329 $self->add_history($line)
330 if (defined $self->{MinLength} && $self->{MinLength} > 0
331 && length($line) >= $self->{MinLength});
332
333 return $line;
334 }
335
336 =item C<AddHistory(LINE1, LINE2, ...)>
337
338 adds the lines to the history of input, from where it can be used if
339 the actual C<readline> is present.
340
341 =cut
342
343 use vars '*addhistory';
344 *addhistory = \&AddHistory; # for backward compatibility
345
346 sub AddHistory {
347 my $self = shift;
348 foreach (@_) {
349 $self->add_history($_);
350 }
351 }
352
353 =item C<IN>, C<OUT>
354
355 return the file handles for input and output or C<undef> if
356 C<readline> input and output cannot be used for Perl.
357
358 =cut
359
360 sub IN { $Attribs{instream}; }
361 sub OUT { $Attribs{outstream}; }
362
363 =item C<MinLine([MAX])>
364
365 If argument C<MAX> is specified, it is an advice on minimal size of
366 line to be included into history. C<undef> means do not include
367 anything into history. Returns the old value.
368
369 =cut
370
371 sub MinLine {
372 my $self = shift;
373 my $old_minlength = $self->{MinLength};
374 $self->{MinLength} = shift;
375 $old_minlength;
376 }
377
378 # findConsole is defined in ReadLine.pm.
379
380 =item C<findConsole>
381
382 returns an array with two strings that give most appropriate names for
383 files for input and output using conventions C<"E<lt>$in">, C<"E<gt>$out">.
384
385 =item C<Attribs>
386
387 returns a reference to a hash which describes internal configuration
388 (variables) of the package. Names of keys in this hash conform to
389 standard conventions with the leading C<rl_> stripped.
390
391 See section "Variables" for supported variables.
392
393 =item C<Features>
394
395 Returns a reference to a hash with keys being features present in
396 current implementation. Several optional features are used in the
397 minimal interface: C<appname> should be present if the first argument
398 to C<new> is recognized, and C<minline> should be present if
399 C<MinLine> method is not dummy. C<autohistory> should be present if
400 lines are put into history automatically (maybe subject to
401 C<MinLine>), and C<addHistory> if C<AddHistory> method is not dummy.
402 C<preput> means the second argument to C<readline> method is processed.
403 C<getHistory> and C<setHistory> denote that the corresponding methods are
404 present. C<tkRunning> denotes that a Tk application may run while ReadLine
405 is getting input.
406
407 =cut
408
409 # Not tested yet. How do I use this?
410 sub newTTY {
411 my ($self, $in, $out) = @_;
412 $Attribs{instream} = $in;
413 $Attribs{outstream} = $out;
414 my $sel = select($out);
415 $| = 1; # for DB::OUT
416 select($sel);
417 }
418
419 =back
420
421 =cut
422
423 # documented later
424 sub CallbackHandlerInstall {
425 my $self = shift;
426 my ($prompt, $lhandler) = @_;
427
428 $Attribs{_callback_handler} = $lhandler;
429
430 # ornament support (now prompt only)
431 $prompt = ${$Attribs{term_set}}[0] . $prompt . ${$Attribs{term_set}}[1];
432
433 $Attribs{completion_entry_function} = $Attribs{_trp_completion_function}
434 if (!defined $Attribs{completion_entry_function}
435 && defined $Attribs{completion_function});
436
437 $self->rl_callback_handler_install($prompt,
438 \&Term::ReadLine::Gnu::XS::_ch_wrapper);
439 }
440
441
442 #
443 # Additional Supported Methods
444 #
445
446 # Documentation is after '__END__' for efficiency.
447
448 # for backward compatibility
449 use vars qw(*AddDefun *BindKey *UnbindKey *ParseAndBind *StifleHistory);
450 *AddDefun = \&add_defun;
451 *BindKey = \&bind_key;
452 *UnbindKey = \&unbind_key;
453 *ParseAndBind = \&parse_and_bind;
454 *StifleHistory = \&stifle_history;
455
456 sub SetHistory {
457 my $self = shift;
458 $self->clear_history();
459 $self->AddHistory(@_);
460 }
461
462 sub GetHistory {
463 my $self = shift;
464 $self->history_list();
465 }
466
467 sub ReadHistory {
468 my $self = shift;
469 ! $self->read_history_range(@_);
470 }
471
472 sub WriteHistory {
473 my $self = shift;
474 ! $self->write_history(@_);
475 }
476
477 #
478 # Access Routines for GNU Readline/History Library Variables
479 #
480 package Term::ReadLine::Gnu::Var;
481 use Carp;
482 use strict;
483 use vars qw(%_rl_vars);
484
485 %_rl_vars
486 = (
487 rl_line_buffer => ['S', 0],
488 rl_prompt => ['S', 1],
489 rl_library_version => ['S', 2],
490 rl_terminal_name => ['S', 3],
491 rl_readline_name => ['S', 4],
492 rl_basic_word_break_characters => ['S', 5],
493 rl_basic_quote_characters => ['S', 6],
494 rl_completer_word_break_characters => ['S', 7],
495 rl_completer_quote_characters => ['S', 8],
496 rl_filename_quote_characters => ['S', 9],
497 rl_special_prefixes => ['S', 10],
498 history_no_expand_chars => ['S', 11],
499 history_search_delimiter_chars => ['S', 12],
500 rl_executing_macro => ['S', 13], # GRL4.2
501 history_word_delimiters => ['S', 14], # GRL4.2
502
503 rl_point => ['I', 0],
504 rl_end => ['I', 1],
505 rl_mark => ['I', 2],
506 rl_done => ['I', 3],
507 rl_pending_input => ['I', 4],
508 rl_completion_query_items => ['I', 5],
509 rl_completion_append_character => ['C', 6],
510 rl_ignore_completion_duplicates => ['I', 7],
511 rl_filename_completion_desired => ['I', 8],
512 rl_filename_quoting_desired => ['I', 9],
513 rl_inhibit_completion => ['I', 10],
514 history_base => ['I', 11],
515 history_length => ['I', 12],
516 history_max_entries => ['I', 13],
517 max_input_history => ['I', 13], # before GRL 4.2
518 history_write_timestamps => ['I', 14], # GRL 5.0
519 history_expansion_char => ['C', 15],
520 history_subst_char => ['C', 16],
521 history_comment_char => ['C', 17],
522 history_quotes_inhibit_expansion => ['I', 18],
523 rl_erase_empty_line => ['I', 19], # GRL 4.0
524 rl_catch_signals => ['I', 20], # GRL 4.0
525 rl_catch_sigwinch => ['I', 21], # GRL 4.0
526 rl_already_prompted => ['I', 22], # GRL 4.1
527 rl_num_chars_to_read => ['I', 23], # GRL 4.2
528 rl_dispatching => ['I', 24], # GRL 4.2
529 rl_gnu_readline_p => ['I', 25], # GRL 4.2
530 rl_readline_state => ['I', 26], # GRL 4.2
531 rl_explicit_arg => ['I', 27], # GRL 4.2
532 rl_numeric_arg => ['I', 28], # GRL 4.2
533 rl_editing_mode => ['I', 29], # GRL 4.2
534 rl_attempted_completion_over => ['I', 30], # GRL 4.2
535 rl_completion_type => ['I', 31], # GRL 4.2
536 rl_readline_version => ['I', 32], # GRL 4.2a
537 rl_completion_suppress_append => ['I', 33], # GRL 4.3
538 rl_completion_quote_character => ['C', 34], # GRL 5.0
539 rl_completion_suppress_quote => ['I', 35], # GRL 5.0
540 rl_completion_found_quote => ['I', 36], # GRL 5.0
541 rl_completion_mark_symlink_dirs => ['I', 37], # GRL 4.3
542
543 rl_startup_hook => ['F', 0],
544 rl_event_hook => ['F', 1],
545 rl_getc_function => ['F', 2],
546 rl_redisplay_function => ['F', 3],
547 rl_completion_entry_function => ['F', 4],
548 rl_attempted_completion_function => ['F', 5],
549 rl_filename_quoting_function => ['F', 6],
550 rl_filename_dequoting_function => ['F', 7],
551 rl_char_is_quoted_p => ['F', 8],
552 rl_ignore_some_completions_function => ['F', 9],
553 rl_directory_completion_hook => ['F', 10],
554 history_inhibit_expansion_function => ['F', 11],
555 rl_pre_input_hook => ['F', 12], # GRL 4.0
556 rl_completion_display_matches_hook => ['F', 13], # GRL 4.0
557 rl_completion_word_break_hook => ['F', 14], # GRL 5.0
558 rl_prep_term_function => ['F', 15], # GRL 4.2
559 rl_deprep_term_function => ['F', 16], # GRL 4.2
560
561 rl_instream => ['IO', 0],
562 rl_outstream => ['IO', 1],
563
564 rl_executing_keymap => ['K', 0],
565 rl_binding_keymap => ['K', 1],
566
567 rl_last_func => ['LF', 0],
568 );
569
570 sub TIESCALAR {
571 my $class = shift;
572 my $name = shift;
573 return bless \$name, $class;
574 }
575
576 sub FETCH {
577 my $self = shift;
578 confess "wrong type" unless ref $self;
579
580 my $name = $$self;
581 if (! defined $_rl_vars{$name}) {
582 confess "Term::ReadLine::Gnu::Var::FETCH: Unknown variable name `$name'\n";
583 return undef ;
584 }
585
586 my ($type, $id) = @{$_rl_vars{$name}};
587 if ($type eq 'S') {
588 return _rl_fetch_str($id);
589 } elsif ($type eq 'I') {
590 return _rl_fetch_int($id);
591 } elsif ($type eq 'C') {
592 return chr(_rl_fetch_int($id));
593 } elsif ($type eq 'F') {
594 return _rl_fetch_function($id);
595 } elsif ($type eq 'IO') {
596 return _rl_fetch_iostream($id);
597 } elsif ($type eq 'K') {
598 return _rl_fetch_keymap($id);
599 } elsif ($type eq 'LF') {
600 return _rl_fetch_last_func();
601 } else {
602 carp "Term::ReadLine::Gnu::Var::FETCH: Illegal type `$type'\n";
603 return undef;
604 }
605 }
606
607 sub STORE {
608 my $self = shift;
609 confess "wrong type" unless ref $self;
610
611 my $name = $$self;
612 if (! defined $_rl_vars{$name}) {
613 confess "Term::ReadLine::Gnu::Var::STORE: Unknown variable name `$name'\n";
614 return undef ;
615 }
616
617 my $value = shift;
618 my ($type, $id) = @{$_rl_vars{$name}};
619 if ($type eq 'S') {
620 if ($name eq 'rl_line_buffer') {
621 return _rl_store_rl_line_buffer($value);
622 } else {
623 return _rl_store_str($value, $id);
624 }
625 } elsif ($type eq 'I') {
626 return _rl_store_int($value, $id);
627 } elsif ($type eq 'C') {
628 return chr(_rl_store_int(ord($value), $id));
629 } elsif ($type eq 'F') {
630 return _rl_store_function($value, $id);
631 } elsif ($type eq 'IO') {
632 return _rl_store_iostream($value, $id);
633 } elsif ($type eq 'K' || $type eq 'LF') {
634 carp "Term::ReadLine::Gnu::Var::STORE: read only variable `$name'\n";
635 return undef;
636 } else {
637 carp "Term::ReadLine::Gnu::Var::STORE: Illegal type `$type'\n";
638 return undef;
639 }
640 }
641
642 package Term::ReadLine::Gnu;
643 use Carp;
644 use strict;
645
646 #
647 # set value of %Attribs
648 #
649
650 # Tie all Readline/History variables
651 foreach (keys %Term::ReadLine::Gnu::Var::_rl_vars) {
652 my $name;
653 ($name = $_) =~ s/^rl_//; # strip leading `rl_'
654 tie $Attribs{$name}, 'Term::ReadLine::Gnu::Var', $_;
655 }
656
657 # add reference to some functions
658 {
659 my ($name, $fname);
660 no strict 'refs'; # allow symbolic reference
661 map {
662 ($name = $_) =~ s/^rl_//; # strip leading `rl_'
663 $fname = 'Term::ReadLine::Gnu::XS::' . $_;
664 $Attribs{$name} = \&$fname; # symbolic reference
665 } qw(rl_getc
666 rl_redisplay
667 rl_callback_read_char
668 rl_display_match_list
669 rl_filename_completion_function
670 rl_username_completion_function
671 list_completion_function
672 _trp_completion_function);
673 # auto-split subroutine cannot be processed in the map loop above
674 use strict 'refs';
675 $Attribs{shadow_redisplay} = \&Term::ReadLine::Gnu::XS::shadow_redisplay;
676 $Attribs{Tk_getc} = \&Term::ReadLine::Gnu::XS::Tk_getc;
677 $Attribs{list_completion_function} = \&Term::ReadLine::Gnu::XS::list_completion_function;
678 }
679
680 package Term::ReadLine::Gnu::AU;
681 use Carp;
682 no strict qw(refs vars);
683
684 sub AUTOLOAD {
685 { $AUTOLOAD =~ s/.*:://; } # preserve match data
686 my $name;
687 if (exists $Term::ReadLine::Gnu::XS::{"rl_$AUTOLOAD"}) {
688 $name = "Term::ReadLine::Gnu::XS::rl_$AUTOLOAD";
689 } elsif (exists $Term::ReadLine::Gnu::XS::{"$AUTOLOAD"}) {
690 $name = "Term::ReadLine::Gnu::XS::$AUTOLOAD";
691 } else {
692 croak "Cannot do `$AUTOLOAD' in Term::ReadLine::Gnu";
693 }
694 local $^W = 0; # Why is this line necessary ?
695 *$AUTOLOAD = sub { shift; &$name(@_); };
696 goto &$AUTOLOAD;
697 }
698 1;
699 __END__
700
701
702 =head2 C<Term::ReadLine::Gnu> Functions
703
704 All these GNU Readline/History Library functions are callable via
705 method interface and have names which conform to standard conventions
706 with the leading C<rl_> stripped.
707
708 Almost methods have lower level functions in
709 C<Term::ReadLine::Gnu::XS> package. To use them full qualified name
710 is required. Using method interface is preferred.
711
712 =over 4
713
714 =item Readline Convenience Functions
715
716 =over 4
717
718 =item Naming Function
719
720 =over 4
721
722 =item C<add_defun(NAME, FUNC [,KEY=-1])>
723
724 Add name to the Perl function C<FUNC>. If optional argument C<KEY> is
725 specified, bind it to the C<FUNC>. Returns reference to
726 C<FunctionPtr>.
727
728 Example:
729 # name name `reverse-line' to a function reverse_line(),
730 # and bind it to "\C-t"
731 $term->add_defun('reverse-line', \&reverse_line, ord "\ct");
732
733 =back
734
735 =item Selecting a Keymap
736
737 =over 4
738
739 =item C<make_bare_keymap>
740
741 Keymap rl_make_bare_keymap()
742
743 =item C<copy_keymap(MAP)>
744
745 Keymap rl_copy_keymap(Keymap|str map)
746
747 =item C<make_keymap>
748
749 Keymap rl_make_keymap()
750
751 =item C<discard_keymap(MAP)>
752
753 Keymap rl_discard_keymap(Keymap|str map)
754
755 =item C<get_keymap>
756
757 Keymap rl_get_keymap()
758
759 =item C<set_keymap(MAP)>
760
761 Keymap rl_set_keymap(Keymap|str map)
762
763 =item C<get_keymap_by_name(NAME)>
764
765 Keymap rl_get_keymap_by_name(str name)
766
767 =item C<get_keymap_name(MAP)>
768
769 str rl_get_keymap_name(Keymap map)
770
771 =back
772
773 =item Binding Keys
774
775 =over 4
776
777 =item C<bind_key(KEY, FUNCTION [,MAP])>
778
779 int rl_bind_key(int key, FunctionPtr|str function,
780 Keymap|str map = rl_get_keymap())
781
782 Bind C<KEY> to the C<FUNCTION>. C<FUNCTION> is the name added by the
783 C<add_defun> method. If optional argument C<MAP> is specified, binds
784 in C<MAP>. Returns non-zero in case of error.
785
786 =item C<bind_key_if_unbound(KEY, FUNCTION [,MAP])>
787
788 int rl_bind_key_if_unbound(int key, FunctionPtr|str function,
789 Keymap|str map = rl_get_keymap()) #GRL5.0
790
791 =item C<unbind_key(KEY [,MAP])>
792
793 int rl_unbind_key(int key, Keymap|str map = rl_get_keymap())
794
795 Bind C<KEY> to the null function. Returns non-zero in case of error.
796
797 =item C<unbind_function(FUNCTION [,MAP])>
798
799 int rl_unbind_function(FunctionPtr|str function,
800 Keymap|str map = rl_get_keymap())
801
802 =item C<unbind_command(COMMAND [,MAP])>
803
804 int rl_unbind_command(str command,
805 Keymap|str map = rl_get_keymap())
806
807 =item C<bind_keyseq(KEYSEQ, FUNCTION [,MAP])>
808
809 int rl_bind_keyseq(str keyseq, FunctionPtr|str function,
810 Keymap|str map = rl_get_keymap()) # GRL 5.0
811
812 =item C<set_key(KEYSEQ, FUNCTION [,MAP])>
813
814 int rl_set_key(str keyseq, FunctionPtr|str function,
815 Keymap|str map = rl_get_keymap())
816
817 =item C<bind_keyseq_if_unbound(KEYSEQ, FUNCTION [,MAP])>
818
819 int rl_bind_keyseq_if_unbound(str keyseq, FunctionPtr|str function,
820 Keymap|str map = rl_get_keymap()) # GRL 5.0
821
822 =item C<generic_bind(TYPE, KEYSEQ, DATA, [,MAP])>
823
824 int rl_generic_bind(int type, str keyseq,
825 FunctionPtr|Keymap|str data,
826 Keymap|str map = rl_get_keymap())
827
828 =item C<parse_and_bind(LINE)>
829
830 void rl_parse_and_bind(str line)
831
832 Parse C<LINE> as if it had been read from the F<~/.inputrc> file and
833 perform any key bindings and variable assignments found. For more
834 detail see 'GNU Readline Library Manual'.
835
836 =item C<read_init_file([FILENAME])>
837
838 int rl_read_init_file(str filename = '~/.inputrc')
839
840 =back
841
842 =item Associating Function Names and Bindings
843
844 =over 4
845
846 =item C<named_function(NAME)>
847
848 FunctionPtr rl_named_function(str name)
849
850 =item C<get_function_name(FUNCTION)>
851
852 str rl_get_function_name(FunctionPtr function)
853
854 =item C<function_of_keyseq(KEYMAP [,MAP])>
855
856 (FunctionPtr|Keymap|str data, int type)
857 rl_function_of_keyseq(str keyseq,
858 Keymap|str map = rl_get_keymap())
859
860 =item C<invoking_keyseqs(FUNCTION [,MAP])>
861
862 (@str) rl_invoking_keyseqs(FunctionPtr|str function,
863 Keymap|str map = rl_get_keymap())
864
865 =item C<function_dumper([READABLE])>
866
867 void rl_function_dumper(int readable = 0)
868
869 =item C<list_funmap_names>
870
871 void rl_list_funmap_names()
872
873 =item C<funmap_names>
874
875 (@str) rl_funmap_names()
876
877 =item C<add_funmap_entry(NAME, FUNCTION)>
878
879 int rl_add_funmap_entry(char *name, FunctionPtr|str function)
880
881 =back
882
883 =item Allowing Undoing
884
885 =over 4
886
887 =item C<begin_undo_group>
888
889 int rl_begin_undo_group()
890
891 =item C<end_undo_group>
892
893 int rl_end_undo_group()
894
895 =item C<add_undo(WHAT, START, END, TEXT)>
896
897 int rl_add_undo(int what, int start, int end, str text)
898
899 =item C<free_undo_list>
900
901 void rl_free_undo_list()
902
903 =item C<do_undo>
904
905 int rl_do_undo()
906
907 =item C<modifying([START [,END]])>
908
909 int rl_modifying(int start = 0, int end = rl_end)
910
911 =back
912
913 =item Redisplay
914
915 =over 4
916
917 =item C<redisplay>
918
919 void rl_redisplay()
920
921 =item C<forced_update_display>
922
923 int rl_forced_update_display()
924
925 =item C<on_new_line>
926
927 int rl_on_new_line()
928
929 =item C<on_new_line_with_prompt>
930
931 int rl_on_new_line_with_prompt() # GRL 4.1
932
933 =item C<reset_line_state>
934
935 int rl_reset_line_state()
936
937 =item C<rl_show_char(C)>
938
939 int rl_show_char(int c)
940
941 =item C<message(FMT[, ...])>
942
943 int rl_message(str fmt, ...)
944
945 =item C<crlf>
946
947 int rl_crlf() # GRL 4.2
948
949 =item C<clear_message>
950
951 int rl_clear_message()
952
953 =item C<save_prompt>
954
955 void rl_save_prompt()
956
957 =item C<restore_prompt>
958
959 void rl_restore_prompt()
960
961 =item C<expand_prompt(PROMPT)>
962
963 int rl_expand_prompt(str prompt) # GRL 4.2
964
965 =item C<set_prompt(PROMPT)>
966
967 int rl_set_prompt(const str prompt) # GRL 4.2
968
969 =back
970
971 =item Modifying Text
972
973 =over 4
974
975 =item C<insert_text(TEXT)>
976
977 int rl_insert_text(str text)
978
979 =item C<delete_text([START [,END]])>
980
981 int rl_delete_text(int start = 0, int end = rl_end)
982
983 =item C<copy_text([START [,END]])>
984
985 str rl_copy_text(int start = 0, int end = rl_end)
986
987 =item C<kill_text([START [,END]])>
988
989 int rl_kill_text(int start = 0, int end = rl_end)
990
991 =item C<push_macro_input(MACRO)>
992
993 int rl_push_macro_input(str macro)
994
995 =back
996
997 =item Character Input
998
999 =over 4
1000
1001 =item C<read_key>
1002
1003 int rl_read_key()
1004
1005 =item C<getc(STREAM)>
1006
1007 int rl_getc(FILE *STREAM)
1008
1009 =item C<stuff_char(C)>
1010
1011 int rl_stuff_char(int c)
1012
1013 =item C<execute_next(C)>
1014
1015 int rl_execute_next(int c) # GRL 4.2
1016
1017 =item C<clear_pending_input()>
1018
1019 int rl_clear_pending_input() # GRL 4.2
1020
1021 =item C<set_keyboard_input_timeout(uSEC)>
1022
1023 int rl_set_keyboard_input_timeout(int usec) # GRL 4.2
1024
1025 =back
1026
1027 =item Terminal Management
1028
1029 =over 4
1030
1031 =item C<prep_terminal(META_FLAG)>
1032
1033 void rl_prep_terminal(int META_FLAG) # GRL 4.2
1034
1035 =item C<deprep_terminal()>
1036
1037 void rl_deprep_terminal() # GRL 4.2
1038
1039 =item C<tty_set_default_bindings(KMAP)>
1040
1041 void rl_tty_set_default_bindings([Keymap KMAP]) # GRL 4.2
1042
1043 =item C<tty_unset_default_bindings(KMAP)>
1044
1045 void rl_tty_unset_default_bindings([Keymap KMAP]) # GRL 5.0
1046
1047 =item C<reset_terminal([TERMINAL_NAME])>
1048
1049 int rl_reset_terminal(str terminal_name = getenv($TERM)) # GRL 4.2
1050
1051 =back
1052
1053 =item Utility Functions
1054
1055 =over 4
1056
1057 =item C<replace_line(TEXT [,CLEAR_UNDO]>
1058
1059 int rl_replace_line(str text, int clear_undo) # GRL 4.3
1060
1061 =item C<initialize>
1062
1063 int rl_initialize()
1064
1065 =item C<ding>
1066
1067 int rl_ding()
1068
1069 =item C<alphabetic(C)>
1070
1071 int rl_alphabetic(int C)
1072
1073 =item C<display_match_list(MATCHES [,LEN [,MAX]])>
1074
1075 void rl_display_match_list(\@matches, len = $#maches, max) # GRL 4.0
1076
1077 Since the first element of an array @matches as treated as a possible
1078 completion, it is not displayed. See the descriptions of
1079 C<completion_matches()>.
1080
1081 When C<MAX> is ommited, the max length of an item in @matches is used.
1082
1083 =back
1084
1085 =item Miscellaneous Functions
1086
1087 =over 4
1088
1089 =item C<macro_bind(KEYSEQ, MACRO [,MAP])>
1090
1091 int rl_macro_bind(const str keyseq, const str macro, Keymap map)
1092
1093 =item C<macro_dumper(READABLE)>
1094
1095 int rl_macro_dumper(int readline)
1096
1097 =item C<variable_bind(VARIABLE, VALUE)>
1098
1099 int rl_variable_bind(const str variable, const str value)
1100
1101 =item C<variable_dumper(READABLE)>
1102
1103 int rl_variable_dumper(int readline)
1104
1105 =item C<set_paren_blink_timeout(uSEC)>
1106
1107 int rl_set_paren_blink_timeout(usec) # GRL 4.2
1108
1109 =item C<get_termcap(cap)>
1110
1111 str rl_get_termcap(cap)
1112
1113 =back
1114
1115 =item Alternate Interface
1116
1117 =over 4
1118
1119 =item C<callback_handler_install(PROMPT, LHANDLER)>
1120
1121 void rl_callback_handler_install(str prompt, pfunc lhandler)
1122
1123 =item C<callback_read_char>
1124
1125 void rl_callback_read_char()
1126
1127 =item C<callback_handler_remove>
1128
1129 void rl_callback_handler_remove()
1130
1131 =back
1132
1133 =back
1134
1135 =item Readline Signal Handling
1136
1137 =over 4
1138
1139 =item C<cleanup_after_signal>
1140
1141 void rl_cleanup_after_signal() # GRL 4.0
1142
1143 =item C<free_line_state>
1144
1145 void rl_free_line_state() # GRL 4.0
1146
1147 =item C<reset_after_signal>
1148
1149 void rl_reset_after_signal() # GRL 4.0
1150
1151 =item C<resize_terminal>
1152
1153 void rl_resize_terminal() # GRL 4.0
1154
1155 =item C<set_screen_size(ROWS, COLS)>
1156
1157 void rl_set_screen_size(int ROWS, int COLS) # GRL 4.2
1158
1159 =item C<get_screen_size()>
1160
1161 (int rows, int cols) rl_get_screen_size() # GRL 4.2
1162
1163 =item C<set_signals>
1164
1165 int rl_set_signals() # GRL 4.0
1166
1167 =item C<clear_signals>
1168
1169 int rl_clear_signals() # GRL 4.0
1170
1171 =back
1172
1173 =item Completion Functions
1174
1175 =over 4
1176
1177 =item C<complete_internal([WHAT_TO_DO])>
1178
1179 int rl_complete_internal(int what_to_do = TAB)
1180
1181 =item C<completion_mode(FUNCTION)>
1182
1183 int rl_completion_mode(FunctionPtr|str function)
1184
1185 =item C<completion_matches(TEXT [,FUNC])>
1186
1187 (@str) rl_completion_matches(str text,
1188 pfunc func = filename_completion_function)
1189
1190 =item C<filename_completion_function(TEXT, STATE)>
1191
1192 str rl_filename_completion_function(str text, int state)
1193
1194 =item C<username_completion_function(TEXT, STATE)>
1195
1196 str rl_username_completion_function(str text, int state)
1197
1198 =item C<list_completion_function(TEXT, STATE)>
1199
1200 str list_completion_function(str text, int state)
1201
1202 =back
1203
1204 =item History Functions
1205
1206 =over 4
1207
1208 =item Initializing History and State Management
1209
1210 =over 4
1211
1212 =item C<using_history>
1213
1214 void using_history()
1215
1216 =back
1217
1218 =item History List Management
1219
1220 =over 4
1221
1222 =item C<addhistory(STRING[, STRING, ...])>
1223
1224 void add_history(str string)
1225
1226 =item C<StifleHistory(MAX)>
1227
1228 int stifle_history(int max|undef)
1229
1230 stifles the history list, remembering only the last C<MAX> entries.
1231 If C<MAX> is undef, remembers all entries. This is a replacement
1232 of unstifle_history().
1233
1234 =item C<unstifle_history>
1235
1236 int unstifle_history()
1237
1238 This is equivalent with 'stifle_history(undef)'.
1239
1240 =item C<SetHistory(LINE1 [, LINE2, ...])>
1241
1242 sets the history of input, from where it can be used if the actual
1243 C<readline> is present.
1244
1245 =item C<add_history_time(STRING)>
1246
1247 void add_history_time(str string) # GRL 5.0
1248
1249 =item C<remove_history(WHICH)>
1250
1251 str remove_history(int which)
1252
1253 =item C<replace_history_entry(WHICH, LINE)>
1254
1255 str replace_history_entry(int which, str line)
1256
1257 =item C<clear_history>
1258
1259 void clear_history()
1260
1261 =item C<history_is_stifled>
1262
1263 int history_is_stifled()
1264
1265 =back
1266
1267 =item Information About the History List
1268
1269 =over 4
1270
1271 =item C<where_history>
1272
1273 int where_history()
1274
1275 =item C<current_history>
1276
1277 str current_history()
1278
1279 =item C<history_get(OFFSET)>
1280
1281 str history_get(offset)
1282
1283 =item C<history_get_time(OFFSET)>
1284
1285 time_t history_get_time(offset)
1286
1287 =item C<history_total_bytes>
1288
1289 int history_total_bytes()
1290
1291 =item C<GetHistory>
1292
1293 returns the history of input as a list, if actual C<readline> is present.
1294
1295 =back
1296
1297 =item Moving Around the History List
1298
1299 =over 4
1300
1301 =item C<history_set_pos(POS)>
1302
1303 int history_set_pos(int pos)
1304
1305 =item C<previous_history>
1306
1307 str previous_history()
1308
1309 =item C<next_history>
1310
1311 str next_history()
1312
1313 =back
1314
1315 =item Searching the History List
1316
1317 =over 4
1318
1319 =item C<history_search(STRING [,DIRECTION])>
1320
1321 int history_search(str string, int direction = -1)
1322
1323 =item C<history_search_prefix(STRING [,DIRECTION])>
1324
1325 int history_search_prefix(str string, int direction = -1)
1326
1327 =item C<history_search_pos(STRING [,DIRECTION [,POS]])>
1328
1329 int history_search_pos(str string,
1330 int direction = -1,
1331 int pos = where_history())
1332
1333 =back
1334
1335 =item Managing the History File
1336
1337 =over 4
1338
1339 =item C<ReadHistory([FILENAME [,FROM [,TO]]])>
1340
1341 int read_history(str filename = '~/.history',
1342 int from = 0, int to = -1)
1343
1344 int read_history_range(str filename = '~/.history',
1345 int from = 0, int to = -1)
1346
1347 adds the contents of C<FILENAME> to the history list, a line at a
1348 time. If C<FILENAME> is false, then read from F<~/.history>. Start
1349 reading at line C<FROM> and end at C<TO>. If C<FROM> is omitted or
1350 zero, start at the beginning. If C<TO> is omitted or less than
1351 C<FROM>, then read until the end of the file. Returns true if
1352 successful, or false if not. C<read_history()> is an aliase of
1353 C<read_history_range()>.
1354
1355 =item C<WriteHistory([FILENAME])>
1356
1357 int write_history(str filename = '~/.history')
1358
1359 writes the current history to C<FILENAME>, overwriting C<FILENAME> if
1360 necessary. If C<FILENAME> is false, then write the history list to
1361 F<~/.history>. Returns true if successful, or false if not.
1362
1363
1364 =item C<append_history(NELEMENTS [,FILENAME])>
1365
1366 int append_history(int nelements, str filename = '~/.history')
1367
1368 =item C<history_truncate_file([FILENAME [,NLINES]])>
1369
1370 int history_truncate_file(str filename = '~/.history',
1371 int nlines = 0)
1372
1373 =back
1374
1375 =item History Expansion
1376
1377 =over 4
1378
1379 =item C<history_expand(LINE)>
1380
1381 (int result, str expansion) history_expand(str line)
1382
1383 Note that this function returns C<expansion> in scalar context.
1384
1385 =item C<get_history_event(STRING, CINDEX [,QCHAR])>
1386
1387 (str text, int cindex) = get_history_event(str string,
1388 int cindex,
1389 char qchar = '\0')
1390
1391 =item C<history_tokenize(LINE)>
1392
1393 (@str) history_tokenize(str line)
1394
1395 =item C<history_arg_extract(LINE, [FIRST [,LAST]])>
1396
1397 str history_arg_extract(str line, int first = 0, int last = '$')
1398
1399 =back
1400
1401 =back
1402
1403 =back
1404
1405 =head2 C<Term::ReadLine::Gnu> Variables
1406
1407 Following GNU Readline/History Library variables can be accessed from
1408 Perl program. See 'GNU Readline Library Manual' and ' GNU History
1409 Library Manual' for each variable. You can access them with
1410 C<Attribs> methods. Names of keys in this hash conform to standard
1411 conventions with the leading C<rl_> stripped.
1412
1413 Examples:
1414
1415 $attribs = $term->Attribs;
1416 $v = $attribs->{library_version}; # rl_library_version
1417 $v = $attribs->{history_base}; # history_base
1418
1419 =over 4
1420
1421 =item Readline Variables
1422
1423 str rl_line_buffer
1424 int rl_point
1425 int rl_end
1426 int rl_mark
1427 int rl_done
1428 int rl_num_chars_to_read (GRL 4.2)
1429 int rl_pending_input
1430 int rl_dispatching (GRL 4.2)
1431 int rl_erase_empty_line (GRL 4.0)
1432 str rl_prompt (read only)
1433 int rl_already_prompted (GRL 4.1)
1434 str rl_library_version (read only)
1435 int rl_readline_version (read only)
1436 int rl_gnu_readline_p (GRL 4.2)
1437 str rl_terminal_name
1438 str rl_readline_name
1439 filehandle rl_instream
1440 filehandle rl_outstream
1441 pfunc rl_startup_hook
1442 pfunc rl_pre_input_hook (GRL 4.0)
1443 pfunc rl_event_hook
1444 pfunc rl_getc_function
1445 pfunc rl_redisplay_function
1446 pfunc rl_prep_term_function (GRL 4.2)
1447 pfunc rl_deprep_term_function (GRL 4.2)
1448 pfunc rl_last_func (GRL 4.2)
1449 Keymap rl_executing_keymap (read only)
1450 Keymap rl_binding_keymap (read only)
1451 str rl_executing_macro (GRL 4.2)
1452 int rl_readline_state (GRL 4.2)
1453 int rl_explicit_arg (GRL 4.2)
1454 int rl_numeric_arg (GRL 4.2)
1455 int rl_editing_mode (GRL 4.2)
1456
1457 =item Signal Handling Variables
1458
1459 int rl_catch_signals (GRL 4.0)
1460 int rl_catch_sigwinch (GRL 4.0)
1461
1462 =item Completion Variables
1463
1464 pfunc rl_completion_entry_function
1465 pfunc rl_attempted_completion_function
1466 pfunc rl_filename_quoting_function
1467 pfunc rl_filename_dequoting_function
1468 pfunc rl_char_is_quoted_p
1469 int rl_completion_query_items
1470 str rl_basic_word_break_characters
1471 str rl_basic_quote_characters
1472 str rl_completer_word_break_characters
1473 pfunc rl_completion_word_break_hook (GRL 5.0)
1474 str rl_completer_quote_characters
1475 str rl_filename_quote_characters
1476 str rl_special_prefixes
1477 int rl_completion_append_character
1478 int rl_completion_suppress_append (GRL 4.3)
1479 int rl_completion_quote_charactor (GRL 5.0)
1480 int rl_completion_suppress_quote (GRL 5.0)
1481 int rl_completion_found_quote (GRL 5.0)
1482 int rl_completion_mark_symlink_dirs (GRL 4.3)
1483 int rl_ignore_completion_duplicates
1484 int rl_filename_completion_desired
1485 int rl_filename_quoting_desired
1486 int rl_attempted_completion_over (GRL 4.2)
1487 int rl_completion_type (GRL 4.2)
1488 int rl_inhibit_completion
1489 pfunc rl_ignore_some_completion_function
1490 pfunc rl_directory_completion_hook
1491 pfunc rl_completion_display_matches_hook (GRL 4.0)
1492
1493 =item History Variables
1494
1495 int history_base
1496 int history_length
1497 int history_max_entries (called `max_input_history'. read only)
1498 int history_write_timestamps (GRL 5.0)
1499 char history_expansion_char
1500 char history_subst_char
1501 char history_comment_char
1502 str history_word_delimiters (GRL 4.2)
1503 str history_no_expand_chars
1504 str history_search_delimiter_chars
1505 int history_quotes_inhibit_expansion
1506 pfunc history_inhibit_expansion_function
1507
1508 =item Function References
1509
1510 rl_getc
1511 rl_redisplay
1512 rl_callback_read_char
1513 rl_display_match_list
1514 rl_filename_completion_function
1515 rl_username_completion_function
1516 list_completion_function
1517 shadow_redisplay
1518 Tk_getc
1519
1520 =back
1521
1522 =head2 Custom Completion
1523
1524 In this section variables and functions for custom completion is
1525 described with examples.
1526
1527 Most of descriptions in this section is cited from GNU Readline
1528 Library manual.
1529
1530 =over 4
1531
1532 =item C<rl_completion_entry_function>
1533
1534 This variable holds reference refers to a generator function for
1535 C<completion_matches()>.
1536
1537 A generator function is called repeatedly from
1538 C<completion_matches()>, returning a string each time. The arguments
1539 to the generator function are C<TEXT> and C<STATE>. C<TEXT> is the
1540 partial word to be completed. C<STATE> is zero the first time the
1541 function is called, allowing the generator to perform any necessary
1542 initialization, and a positive non-zero integer for each subsequent
1543 call. When the generator function returns C<undef> this signals
1544 C<completion_matches()> that there are no more possibilities left.
1545
1546 If the value is undef, built-in C<filename_completion_function> is
1547 used.
1548
1549 A sample generator function, C<list_completion_function>, is defined
1550 in Gnu.pm. You can use it as follows;
1551
1552 use Term::ReadLine;
1553 ...
1554 my $term = new Term::ReadLine 'sample';
1555 my $attribs = $term->Attribs;
1556 ...
1557 $attribs->{completion_entry_function} =
1558 $attribs->{list_completion_function};
1559 ...
1560 $attribs->{completion_word} =
1561 [qw(reference to a list of words which you want to use for completion)];
1562 $term->readline("custom completion>");
1563
1564 See also C<completion_matches>.
1565
1566 =item C<rl_attempted_completion_function>
1567
1568 A reference to an alternative function to create matches.
1569
1570 The function is called with C<TEXT>, C<LINE_BUFFER>, C<START>, and
1571 C<END>. C<LINE_BUFFER> is a current input buffer string. C<START>
1572 and C<END> are indices in C<LINE_BUFFER> saying what the boundaries of
1573 C<TEXT> are.
1574
1575 If this function exists and returns null list or C<undef>, or if this
1576 variable is set to C<undef>, then an internal function
1577 C<rl_complete()> will call the value of
1578 C<$rl_completion_entry_function> to generate matches, otherwise the
1579 array of strings returned will be used.
1580
1581 The default value of this variable is C<undef>. You can use it as follows;
1582
1583 use Term::ReadLine;
1584 ...
1585 my $term = new Term::ReadLine 'sample';
1586 my $attribs = $term->Attribs;
1587 ...
1588 sub sample_completion {
1589 my ($text, $line, $start, $end) = @_;
1590 # If first word then username completion, else filename completion
1591 if (substr($line, 0, $start) =~ /^\s*$/) {
1592 return $term->completion_matches($text,
1593 $attribs->{'username_completion_function'});
1594 } else {
1595 return ();
1596 }
1597 }
1598 ...
1599 $attribs->{attempted_completion_function} = \&sample_completion;
1600
1601 =item C<completion_matches(TEXT, ENTRY_FUNC)>
1602
1603 Returns an array of strings which is a list of completions for
1604 C<TEXT>. If there are no completions, returns C<undef>. The first
1605 entry in the returned array is the substitution for C<TEXT>. The
1606 remaining entries are the possible completions.
1607
1608 C<ENTRY_FUNC> is a generator function which has two arguments, and
1609 returns a string. The first argument is C<TEXT>. The second is a
1610 state argument; it is zero on the first call, and non-zero on
1611 subsequent calls. C<ENTRY_FUNC> returns a C<undef> to the caller when
1612 there are no more matches.
1613
1614 If the value of C<ENTRY_FUNC> is undef, built-in
1615 C<filename_completion_function> is used.
1616
1617 C<completion_matches> is a Perl wrapper function of an internal
1618 function C<completion_matches()>. See also
1619 C<$rl_completion_entry_function>.
1620
1621 =item C<completion_function>
1622
1623 A variable whose content is a reference to a function which returns a
1624 list of candidates to complete.
1625
1626 This variable is compatible with C<Term::ReadLine::Perl> and very easy
1627 to use.
1628
1629 use Term::ReadLine;
1630 ...
1631 my $term = new Term::ReadLine 'sample';
1632 my $attribs = $term->Attribs;
1633 ...
1634 $attribs->{completion_function} = sub {
1635 my ($text, $line, $start) = @_;
1636 return qw(a list of candidates to complete);
1637 }
1638
1639 =item C<list_completion_function(TEXT, STATE)>
1640
1641 A sample generator function defined by C<Term::ReadLine::Gnu>.
1642 Example code at C<rl_completion_entry_function> shows how to use this
1643 function.
1644
1645 =back
1646
1647 =head2 C<Term::ReadLine::Gnu> Specific Features
1648
1649 =over 4
1650
1651 =item C<Term::ReadLine::Gnu> Specific Functions
1652
1653 =over 4
1654
1655 =item C<CallbackHandlerInstall(PROMPT, LHANDLER)>
1656
1657 This method provides the function C<rl_callback_handler_install()>
1658 with the following addtional feature compatible with C<readline>
1659 method; ornament feature, C<Term::ReadLine::Perl> compatible
1660 completion function, histroy expansion, and addition to history
1661 buffer.
1662
1663 =item C<call_function(FUNCTION, [COUNT [,KEY]])>
1664
1665 int rl_call_function(FunctionPtr|str function, count = 1, key = -1)
1666
1667 =item C<rl_get_all_function_names>
1668
1669 Returns a list of all function names.
1670
1671 =item C<shadow_redisplay>
1672
1673 A redisplay function for password input. You can use it as follows;
1674
1675 $attribs->{redisplay_function} = $attribs->{shadow_redisplay};
1676 $line = $term->readline("password> ");
1677
1678 =item C<rl_filename_list>
1679
1680 Returns candidates of filename to complete. This function can be used
1681 with C<completion_function> and is implemented for the compatibility
1682 with C<Term::ReadLine::Perl>.
1683
1684 =item C<list_completion_function>
1685
1686 See the description of section L<"Custom Completion"|"Custom Completion">.
1687
1688 =back
1689
1690 =item C<Term::ReadLine::Gnu> Specific Variables
1691
1692 =over 4
1693
1694 =item C<do_expand>
1695
1696 When true, the history expansion is enabled. By default false.
1697
1698 =item C<completion_function>
1699
1700 See the description of section L<"Custom Completion"|"Custom Completion">.
1701
1702 =item C<completion_word>
1703
1704 A reference to a list of candidates to complete for
1705 C<list_completion_function>.
1706
1707 =back
1708
1709 =item C<Term::ReadLine::Gnu> Specific Commands
1710
1711 =over 4
1712
1713 =item C<history-expand-line>
1714
1715 The equivalent of the Bash C<history-expand-line> editing command.
1716
1717 =item C<operate-and-get-next>
1718
1719 The equivalent of the Korn shell C<operate-and-get-next-history-line>
1720 editing command and the Bash C<operate-and-get-next>.
1721
1722 This command is bound to C<\C-o> by default for the compatibility with
1723 the Bash and C<Term::ReadLine::Perl>.
1724
1725 =item C<display-readline-version>
1726
1727 Shows the version of C<Term::ReadLine::Gnu> and the one of the GNU
1728 Readline Library.
1729
1730 =item C<change-ornaments>
1731
1732 Change ornaments interactively.
1733
1734 =back
1735
1736 =back
1737
1738 =head1 FILES
1739
1740 =over 4
1741
1742 =item F<~/.inputrc>
1743
1744 Readline init file. Using this file it is possible that you would
1745 like to use a different set of key bindings. When a program which
1746 uses the Readline library starts up, the init file is read, and the
1747 key bindings are set.
1748
1749 Conditional key binding is also available. The program name which is
1750 specified by the first argument of C<new> method is used as the
1751 application construct.
1752
1753 For example, when your program call C<new> method like this;
1754
1755 ...
1756 $term = new Term::ReadLine 'PerlSh';
1757 ...
1758
1759 your F<~/.inputrc> can define key bindings only for it as follows;
1760
1761 ...
1762 $if PerlSh
1763 Meta-Rubout: backward-kill-word
1764 "\C-x\C-r": re-read-init-file
1765 "\e[11~": "Function Key 1"
1766 $endif
1767 ...
1768
1769 =back
1770
1771 =head1 EXPORTS
1772
1773 None.
1774
1775 =head1 SEE ALSO
1776
1777 =over 4
1778
1779 =item GNU Readline Library Manual
1780
1781 =item GNU History Library Manual
1782
1783 =item C<Term::ReadLine>
1784
1785 =item C<Term::ReadLine::Perl> (Term-ReadLine-Perl-xx.tar.gz)
1786
1787 =item F<eg/*> and F<t/*> in the Term::ReadLine::Gnu distribution
1788
1789 =item Articles related to Term::ReadLine::Gnu
1790
1791 =over 4
1792
1793 =item effective perl programming
1794
1795 http://www.usenix.org/publications/login/2000-7/features/effective.html
1796
1797 This article demonstrates how to integrate Term::ReadLine::Gnu into an
1798 interactive command line program.
1799
1800 =item eijiro (Japanese)
1801
1802 http://bulknews.net/lib/columns/02_eijiro/column.html
1803
1804 A command line interface to Eijiro, Japanese-English dictionary
1805 service on WWW.
1806
1807
1808 =back
1809
1810 =item Works which use Term::ReadLine::Gnu
1811
1812 =over 4
1813
1814 =item Perl Debugger
1815
1816 perl -d
1817
1818 =item The Perl Shell (psh)
1819
1820 http://www.focusresearch.com/gregor/psh/
1821
1822 The Perl Shell is a shell that combines the interactive nature of a
1823 Unix shell with the power of Perl.
1824
1825 A programmable completion feature compatible with bash is implemented.
1826
1827 =item SPP (Synopsys Plus Perl)
1828
1829 http://www.stanford.edu/~jsolomon/SPP/
1830
1831 SPP (Synopsys Plus Perl) is a Perl module that wraps around Synopsys'
1832 shell programs. SPP is inspired by the original dc_perl written by
1833 Steve Golson, but it's an entirely new implementation. Why is it
1834 called SPP and not dc_perl? Well, SPP was written to wrap around any
1835 of Synopsys' shells.
1836
1837 =item PFM (Personal File Manager for Unix/Linux)
1838
1839 http://p-f-m.sourceforge.net/
1840
1841 Pfm is a terminal-based file manager written in Perl, based on PFM.COM
1842 for MS-DOS (originally by Paul Culley and Henk de Heer).
1843
1844 =item The soundgrab
1845
1846 http://rawrec.sourceforge.net/soundgrab/soundgrab.html
1847
1848 soundgrab is designed to help you slice up a big long raw audio file
1849 (by default 44.1 kHz 2 channel signed sixteen bit little endian) and
1850 save your favorite sections to other files. It does this by providing
1851 you with a cassette player like command line interface.
1852
1853 =item PDL (The Perl Data Language)
1854
1855 http://pdl.perl.org/index_en.html
1856
1857 PDL (``Perl Data Language'') gives standard Perl the ability to
1858 compactly store and speedily manipulate the large N-dimensional data
1859 arrays which are the bread and butter of scientific computing.
1860
1861 =item PIQT (Perl Interactive DBI Query Tool)
1862
1863 http://piqt.sourceforge.net/
1864
1865 PIQT is an interactive query tool using the Perl DBI database
1866 interface. It supports ReadLine, provides a built in scripting language
1867 with a Lisp like syntax, an online help system, and uses wrappers to
1868 interface to the DBD modules.
1869
1870 =item Ghostscript Shell
1871
1872 http://www.panix.com/~jdf/gshell/
1873
1874 It provides a friendly way to play with the Ghostscript interpreter,
1875 including command history and auto-completion of Postscript font names
1876 and reserved words.
1877
1878 =item vshnu (the New Visual Shell)
1879
1880 http://www.cs.indiana.edu/~kinzler/vshnu/
1881
1882 A visual shell and CLI shell supplement.
1883
1884 =back
1885
1886 If you know any other works which can be listed here, please let me
1887 know.
1888
1889 =back
1890
1891 =head1 AUTHOR
1892
1893 Hiroo Hayashi C<E<lt>hiroo.hayashi@computer.orgE<gt>>
1894
1895 C<http://www.perl.org/CPAN/authors/Hiroo_HAYASHI/>
1896
1897 =head1 TODO
1898
1899 GTK+ support in addition to Tk.
1900
1901 =head1 BUGS
1902
1903 C<rl_add_defun()> can define up to 16 functions.
1904
1905 Ornament feature works only on prompt strings. It requires very hard
1906 hacking of C<display.c:rl_redisplay()> in GNU Readline library to
1907 ornament input line.
1908
1909 C<newTTY()> is not tested yet.
1910
1911 =cut
+2850
-0
Gnu.xs less more
0 /*
1 * Gnu.xs --- GNU Readline wrapper module
2 *
3 * $Id: Gnu.xs,v 1.108 2004-10-17 12:37:53-05 hiroo Exp $
4 *
5 * Copyright (c) 2004 Hiroo Hayashi. All rights reserved.
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the same terms as Perl itself.
9 */
10
11 #ifdef __cplusplus
12 extern "C" {
13 #endif
14 #define PERLIO_NOT_STDIO 0
15 #include "EXTERN.h"
16 #include "perl.h"
17 #include "XSUB.h"
18 #include "ppport.h"
19 #ifdef __cplusplus
20 }
21 #endif
22
23 #include <stdio.h>
24 #ifdef __CYGWIN__
25 #include <sys/termios.h>
26 #endif /* __CYGWIN__ */
27 #include <readline/readline.h>
28 #include <readline/history.h>
29
30 /*
31 * Perl 5.005 requires an ANSI C Compiler. Good news.
32 * But I should still support legacy C compilers now.
33 */
34 /* Adapted from BSD /usr/include/sys/cdefs.h. */
35 #if defined (__STDC__)
36 # if !defined (PARAMS)
37 # define PARAMS(protos) protos
38 # endif
39 #else /* !__STDC__ */
40 # if !defined (PARAMS)
41 # define PARAMS(protos) ()
42 # endif
43 #endif /* !__STDC__ */
44
45 typedef char * t_xstr; /* string which must be xfreeed */
46
47 /*
48 * compatibility definitions
49 */
50
51 /* rl_last_func() is defined in rlprivate.h */
52 extern Function *rl_last_func;
53
54 /* features introduced by GNU Readline 4.0 */
55 #if (RL_VERSION_MAJOR < 4)
56 extern void rl_extend_line_buffer PARAMS((int));
57 extern char **rl_funmap_names PARAMS((void));
58
59 static int rl_erase_empty_line = 0;
60 static int rl_catch_signals = 1;
61 static int rl_catch_sigwinch = 1;
62 static Function *rl_pre_input_hook;
63 static VFunction *rl_completion_display_matches_hook;
64 static VFunction *rl_prep_term_function;
65 static VFunction *rl_deprep_term_function;
66
67 static void rl_cleanup_after_signal(){};
68 static void rl_free_line_state(){};
69 static void rl_reset_after_signal(){};
70 static void rl_resize_terminal(){};
71 static void rl_prep_terminal(){};
72 static void rl_deprep_terminal(){};
73 /*
74 * Before GNU Readline Library Version 4.0, rl_save_prompt() was
75 * _rl_save_prompt and rl_restore_prompt() was _rl_restore_prompt().
76 */
77 extern void _rl_save_prompt PARAMS((void));
78 extern void _rl_restore_prompt PARAMS((void));
79 static void rl_save_prompt() { _rl_save_prompt(); }
80 static void rl_restore_prompt() { _rl_restore_prompt(); }
81 #endif /* (RL_VERSION_MAJOR < 4) */
82
83 /* features introduced by GNU Readline 4.1 */
84 #if (RL_READLINE_VERSION < 0x0401)
85 static int rl_already_prompted = 0;
86 static int rl_num_chars_to_read = 0;
87 static int rl_gnu_readline_p = 0;
88 #endif /* (RL_READLINE_VERSION < 0x0401) */
89
90 /* features introduced by GNU Readline 4.2 */
91 #if (RL_READLINE_VERSION < 0x0402)
92 /* Provide backwards-compatible entry points for old function names
93 which are rename from readline-4.2. */
94 typedef int rl_command_func_t PARAMS((int, int));
95 typedef char *rl_compentry_func_t PARAMS((const char *, int));
96
97 static char *rl_executing_macro = NULL;
98 static int rl_explicit_arg = 0;
99 static int rl_numeric_arg = 0;
100 static int rl_editing_mode = 0;
101 static int rl_readline_state = 0;
102 static Function *rl_directory_rewrite_hook = NULL;
103 static char *history_word_delimiters = " \t\n;&()|<>";
104 static void
105 rl_free_undo_list ()
106 {
107 free_undo_list ();
108 }
109
110 static int
111 rl_crlf ()
112 {
113 return crlf ();
114 }
115
116 #if (RL_VERSION_MAJOR >= 4)
117 static void
118 rl_tty_set_default_bindings (keymap)
119 Keymap keymap;
120 {
121 rltty_set_default_bindings (keymap);
122 }
123 #endif /* (RL_VERSION_MAJOR >= 4) */
124
125 static int
126 rl_ding ()
127 {
128 return ding ();
129 }
130
131 static char **
132 rl_completion_matches (s, f)
133 char *s;
134 rl_compentry_func_t *f;
135 {
136 return completion_matches (s, (CPFunction *)f);
137 }
138
139 static char *
140 rl_username_completion_function (s, i)
141 const char *s;
142 int i;
143 {
144 return username_completion_function ((char *)s, i);
145 }
146
147 static char *
148 rl_filename_completion_function (s, i)
149 const char *s;
150 int i;
151 {
152 return filename_completion_function ((char *)s, i);
153 }
154
155 /*
156 * In Readline 4.2 many variables, function arguments, and function
157 * return values are now declared `const' where appropriate.
158 */
159 #define CONST
160 #else /* (RL_READLINE_VERSION >= 0x0402) */
161 #define CONST const
162 #endif /* (RL_READLINE_VERSION >= 0x0402) */
163
164 #if (RL_READLINE_VERSION < 0x0403)
165 /* features introduced by GNU Readline 4.2a */
166 static int rl_readline_version = RL_READLINE_VERSION;
167 extern char *rl_get_termcap PARAMS((const char *));
168
169 /* features introduced by GNU Readline 4.3 */
170 static int rl_completion_suppress_append = 0;
171 static int rl_completion_mark_symlink_dirs = 0;
172 #endif /* (RL_READLINE_VERSION < 0x0403) */
173
174 #if (RL_VERSION_MAJOR < 5)
175 /* features introduced by GNU Readline 5.0 */
176 static int history_write_timestamps = 0;
177 static int rl_completion_quote_character = 0;
178 static int rl_completion_suppress_quote = 0;
179 static int rl_completion_found_quote = 0;
180 static Function *rl_completion_word_break_hook = NULL;
181 #endif /* (RL_VERSION_MAJOR < 5) */
182
183 /*
184 * utility/dummy functions
185 */
186 /* from GNU Readline:xmalloc.c */
187 extern char *xmalloc PARAMS((int));
188 extern char *tgetstr PARAMS((const char *, char **));
189 extern int tputs PARAMS((const char *, int, int (*)(int)));
190
191 /*
192 * Using xfree() in GNU Readline Library causes problem with Solaris
193 * 2.5. It seems that the DLL mechanism of Solaris 2.5 links another
194 * xfree() that does not do NULL argument check.
195 * I choose this as default since some other OSs may have same problem.
196 * usemymalloc=n is required.
197 */
198 #ifdef OS2_USEDLL
199 /* from GNU Readline:xmalloc.c */
200 extern char *xfree PARAMS((char *));
201
202 #else /* not OS2_USEDLL */
203 static void
204 xfree (string)
205 char *string;
206 {
207 if (string)
208 free (string);
209 }
210 #endif /* not OS2_USEDLL */
211
212 static char *
213 dupstr(s) /* duplicate string */
214 char *s;
215 {
216 /*
217 * Use xmalloc(), because allocated block will be freed in the GNU
218 * Readline Library routine.
219 * Don't make a macro, because the variable 's' is evaluated twice.
220 */
221 int len = strlen(s) + 1;
222 char *d = xmalloc(len);
223 Copy(s, d, len, char); /* Is Copy() better than strcpy() in XS? */
224 return d;
225 }
226
227 /*
228 * for tputs XS routine
229 */
230 static char *tputs_ptr;
231 static int
232 tputs_char(c)
233 int c;
234 {
235 return *tputs_ptr++ = c;
236 }
237
238 /*
239 * return name of FUNCTION.
240 * I asked Chet Ramey to add this function in readline/bind.c. But he
241 * did not, since he could not find any reasonable excuse.
242 */
243 static const char *
244 rl_get_function_name (function)
245 rl_command_func_t *function;
246 {
247 register int i;
248
249 rl_initialize_funmap ();
250
251 for (i = 0; funmap[i]; i++)
252 if (funmap[i]->function == function)
253 return ((const char *)funmap[i]->name); /* cast is for oldies */
254 return NULL;
255 }
256
257 /*
258 * from readline-4.0:complete.c
259 * Redefine here since the function defined as static in complete.c.
260 * This function is used for default vaule for rl_filename_quoting_function.
261 */
262 static char * rl_quote_filename PARAMS((char *s, int rtype, char *qcp));
263
264 static char *
265 rl_quote_filename (s, rtype, qcp)
266 char *s;
267 int rtype;
268 char *qcp;
269 {
270 char *r;
271
272 r = xmalloc (strlen (s) + 2);
273 *r = *rl_completer_quote_characters;
274 strcpy (r + 1, s);
275 if (qcp)
276 *qcp = *rl_completer_quote_characters;
277 return r;
278 }
279
280 /*
281 * string variable table for _rl_store_str(), _rl_fetch_str()
282 */
283
284 static struct str_vars {
285 char **var;
286 int accessed;
287 int read_only;
288 } str_tbl[] = {
289 /* When you change length of rl_line_buffer, you must call
290 rl_extend_line_buffer(). See _rl_store_rl_line_buffer() */
291 { &rl_line_buffer, 0, 0 }, /* 0 */
292 { &rl_prompt, 0, 1 }, /* 1 */
293 { (char **)&rl_library_version, 0, 1 }, /* 2 */
294 { (char **)&rl_terminal_name, 0, 0 }, /* 3 */
295 { (char **)&rl_readline_name, 0, 0 }, /* 4 */
296
297 { (char **)&rl_basic_word_break_characters, 0, 0 }, /* 5 */
298 { (char **)&rl_basic_quote_characters, 0, 0 }, /* 6 */
299 { (char **)&rl_completer_word_break_characters, 0, 0 }, /* 7 */
300 { (char **)&rl_completer_quote_characters, 0, 0 }, /* 8 */
301 { (char **)&rl_filename_quote_characters, 0, 0 }, /* 9 */
302 { (char **)&rl_special_prefixes, 0, 0 }, /* 10 */
303
304 { &history_no_expand_chars, 0, 0 }, /* 11 */
305 { &history_search_delimiter_chars, 0, 0 }, /* 12 */
306
307 { &rl_executing_macro, 0, 0 }, /* 13 */
308 { &history_word_delimiters, 0, 0 } /* 14 */
309 };
310
311 /*
312 * integer variable table for _rl_store_int(), _rl_fetch_int()
313 */
314
315 static struct int_vars {
316 int *var;
317 int charp;
318 int read_only;
319 } int_tbl[] = {
320 { &rl_point, 0, 0 }, /* 0 */
321 { &rl_end, 0, 0 }, /* 1 */
322 { &rl_mark, 0, 0 }, /* 2 */
323 { &rl_done, 0, 0 }, /* 3 */
324 { &rl_pending_input, 0, 0 }, /* 4 */
325
326 { &rl_completion_query_items, 0, 0 }, /* 5 */
327 { &rl_completion_append_character, 0, 0 }, /* 6 */
328 { &rl_ignore_completion_duplicates, 0, 0 }, /* 7 */
329 { &rl_filename_completion_desired, 0, 0 }, /* 8 */
330 { &rl_filename_quoting_desired, 0, 0 }, /* 9 */
331 { &rl_inhibit_completion, 0, 0 }, /* 10 */
332
333 { &history_base, 0, 0 }, /* 11 */
334 { &history_length, 0, 0 }, /* 12 */
335 #if (RL_READLINE_VERSION >= 0x0402)
336 { &history_max_entries, 0, 1 }, /* 13 */
337 #else /* (RL_READLINE_VERSION < 0x0402) */
338 { &max_input_history, 0, 1 }, /* 13 */
339 #endif /* (RL_READLINE_VERSION < 0x0402) */
340 { &history_write_timestamps, 0, 0 }, /* 14 */
341 { (int *)&history_expansion_char, 1, 0 }, /* 15 */
342 { (int *)&history_subst_char, 1, 0 }, /* 16 */
343 { (int *)&history_comment_char, 1, 0 }, /* 17 */
344 { &history_quotes_inhibit_expansion, 0, 0 }, /* 18 */
345 { &rl_erase_empty_line, 0, 0 }, /* 19 */
346 { &rl_catch_signals, 0, 0 }, /* 20 */
347 { &rl_catch_sigwinch, 0, 0 }, /* 21 */
348 { &rl_already_prompted, 0, 0 }, /* 22 */
349 { &rl_num_chars_to_read, 0, 0 }, /* 23 */
350 { &rl_dispatching, 0, 0 }, /* 24 */
351 { &rl_gnu_readline_p, 0, 1 }, /* 25 */
352 { &rl_readline_state, 0, 0 }, /* 26 */
353 { &rl_explicit_arg, 0, 0 }, /* 27 */
354 { &rl_numeric_arg, 0, 0 }, /* 28 */
355 { &rl_editing_mode, 0, 0 }, /* 29 */
356 { &rl_attempted_completion_over, 0, 0 }, /* 30 */
357 { &rl_completion_type, 0, 0 }, /* 31 */
358 { &rl_readline_version, 0, 1 }, /* 32 */
359 { &rl_completion_suppress_append, 0, 0 }, /* 33 */
360 { &rl_completion_quote_character, 0, 0 }, /* 34 */
361 { &rl_completion_suppress_quote, 0, 0 }, /* 35 */
362 { &rl_completion_found_quote, 0, 0 }, /* 36 */
363 { &rl_completion_mark_symlink_dirs, 0, 0 } /* 37 */
364 };
365
366 /*
367 * PerlIO variables for _rl_store_iostream(), _rl_fetch_iostream()
368 */
369 static PerlIO *instreamPIO = NULL;
370 static PerlIO *outstreamPIO = NULL;
371
372 /*
373 * function pointer variable table for _rl_store_function(),
374 * _rl_fetch_funtion()
375 */
376
377 static int startup_hook_wrapper PARAMS((void));
378 static int event_hook_wrapper PARAMS((void));
379 static int getc_function_wrapper PARAMS((PerlIO *));
380 static void redisplay_function_wrapper PARAMS((void));
381 static char *completion_entry_function_wrapper PARAMS((const char *, int));;
382 static char **attempted_completion_function_wrapper PARAMS((char *, int, int));
383 static char *filename_quoting_function_wrapper PARAMS((char *text, int match_type,
384 char *quote_pointer));
385 static char *filename_dequoting_function_wrapper PARAMS((char *text,
386 int quote_char));
387 static int char_is_quoted_p_wrapper PARAMS((char *text, int index));
388 static void ignore_some_completions_function_wrapper PARAMS((char **matches));
389 static int directory_completion_hook_wrapper PARAMS((char **textp));
390 static int history_inhibit_expansion_function_wrapper PARAMS((char *str, int i));
391 static int pre_input_hook_wrapper PARAMS((void));
392 static void completion_display_matches_hook_wrapper PARAMS((char **matches,
393 int len, int max));
394 static char *completion_word_break_hook_wrapper PARAMS((void));
395 static int prep_term_function_wrapper PARAMS((int meta_flag));
396 static int deprep_term_function_wrapper PARAMS((void));
397 static int directory_rewrite_hook_wrapper PARAMS((char **));
398
399 enum { STARTUP_HOOK, EVENT_HOOK, GETC_FN, REDISPLAY_FN,
400 CMP_ENT, ATMPT_COMP,
401 FN_QUOTE, FN_DEQUOTE, CHAR_IS_QUOTEDP,
402 IGNORE_COMP, DIR_COMP, HIST_INHIBIT_EXP,
403 PRE_INPUT_HOOK, COMP_DISP_HOOK, COMP_WD_BRK_HOOK,
404 PREP_TERM, DEPREP_TERM, DIR_REWRITE
405 };
406
407 static struct fn_vars {
408 Function **rlfuncp; /* GNU Readline Library variable */
409 Function *defaultfn; /* default function */
410 Function *wrapper; /* wrapper function */
411 SV *callback; /* Perl function */
412 } fn_tbl[] = {
413 { &rl_startup_hook, NULL, startup_hook_wrapper, NULL }, /* 0 */
414 { &rl_event_hook, NULL, event_hook_wrapper, NULL }, /* 1 */
415 { &rl_getc_function, rl_getc, getc_function_wrapper, NULL }, /* 2 */
416 {
417 (Function **)&rl_redisplay_function, /* 3 */
418 (Function *)rl_redisplay,
419 (Function *)redisplay_function_wrapper,
420 NULL
421 },
422 {
423 (Function **)&rl_completion_entry_function, /* 4 */
424 NULL,
425 (Function *)completion_entry_function_wrapper,
426 NULL
427 },
428 {
429 (Function **)&rl_attempted_completion_function, /* 5 */
430 NULL,
431 (Function *)attempted_completion_function_wrapper,
432 NULL
433 },
434 {
435 (Function **)&rl_filename_quoting_function, /* 6 */
436 (Function *)rl_quote_filename,
437 (Function *)filename_quoting_function_wrapper,
438 NULL
439 },
440 {
441 (Function **)&rl_filename_dequoting_function, /* 7 */
442 NULL,
443 (Function *)filename_dequoting_function_wrapper,
444 NULL
445 },
446 {
447 (Function **)&rl_char_is_quoted_p, /* 8 */
448 NULL,
449 (Function *)char_is_quoted_p_wrapper,
450 NULL
451 },
452 {
453 (Function **)&rl_ignore_some_completions_function, /* 9 */
454 NULL,
455 (Function *)ignore_some_completions_function_wrapper,
456 NULL
457 },
458 {
459 (Function **)&rl_directory_completion_hook, /* 10 */
460 NULL,
461 (Function *)directory_completion_hook_wrapper,
462 NULL
463 },
464 {
465 (Function **)&history_inhibit_expansion_function, /* 11 */
466 NULL,
467 (Function *)history_inhibit_expansion_function_wrapper,
468 NULL
469 },
470 { &rl_pre_input_hook, NULL, pre_input_hook_wrapper, NULL }, /* 12 */
471 {
472 (Function **)&rl_completion_display_matches_hook, /* 13 */
473 NULL,
474 (Function *)completion_display_matches_hook_wrapper,
475 NULL
476 },
477 {
478 (Function **)&rl_completion_word_break_hook, /* 14 */
479 NULL,
480 (Function *)completion_word_break_hook_wrapper,
481 NULL
482 },
483 {
484 (Function **)&rl_prep_term_function, /* 15 */
485 (Function *)rl_prep_terminal,
486 (Function *)prep_term_function_wrapper,
487 NULL
488 },
489 {
490 (Function **)&rl_deprep_term_function, /* 16 */
491 (Function *)rl_deprep_terminal,
492 (Function *)deprep_term_function_wrapper,
493 NULL
494 },
495 {
496 (Function **)&rl_directory_rewrite_hook, /* 17 */
497 NULL,
498 (Function *)directory_rewrite_hook_wrapper,
499 NULL
500 }
501 };
502
503 /*
504 * Perl function wrappers
505 */
506
507 /*
508 * for rl_voidfunc_t : void fn(void)
509 */
510 static int
511 voidfunc_wrapper(type)
512 int type;
513 {
514 dSP;
515 int count;
516 int ret;
517 SV *svret;
518
519 ENTER;
520 SAVETMPS;
521
522 PUSHMARK(sp);
523 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
524 SPAGAIN;
525
526 if (count != 1)
527 croak("Gnu.xs:voidfunc_wrapper: Internal error\n");
528
529 svret = POPs;
530 ret = SvIOK(svret) ? SvIV(svret) : -1;
531 PUTBACK;
532 FREETMPS;
533 LEAVE;
534 return ret;
535 }
536
537 /*
538 * for rl_vintfunc_t : void fn(int)
539 */
540 static int
541 vintfunc_wrapper(type, arg)
542 int type;
543 int arg;
544 {
545 dSP;
546 int count;
547 int ret;
548 SV *svret;
549
550 ENTER;
551 SAVETMPS;
552
553 PUSHMARK(sp);
554 XPUSHs(sv_2mortal(newSViv(arg)));
555 PUTBACK;
556 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
557 SPAGAIN;
558
559 if (count != 1)
560 croak("Gnu.xs:vintfunc_wrapper: Internal error\n");
561
562 svret = POPs;
563 ret = SvIOK(svret) ? SvIV(svret) : -1;
564 PUTBACK;
565 FREETMPS;
566 LEAVE;
567 return ret;
568 }
569
570 /*
571 * for rl_icppfunc_t : int fn(char **)
572 */
573 static int
574 icppfunc_wrapper(type, arg)
575 int type;
576 char **arg;
577 {
578 dSP;
579 int count;
580 SV *sv;
581 int ret;
582 char *rstr;
583
584 ENTER;
585 SAVETMPS;
586
587 if (arg && *arg) {
588 sv = sv_2mortal(newSVpv(*arg, 0));
589 } else {
590 sv = &PL_sv_undef;
591 }
592
593 PUSHMARK(sp);
594 XPUSHs(sv);
595 PUTBACK;
596
597 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
598
599 SPAGAIN;
600
601 if (count != 1)
602 croak("Gnu.xs:icppfunc_wrapper: Internal error\n");
603
604 ret = POPi;
605
606 rstr = SvPV(sv, PL_na);
607 if (strcmp(*arg, rstr) != 0) {
608 xfree(*arg);
609 *arg = dupstr(rstr);
610 }
611
612 PUTBACK;
613 FREETMPS;
614 LEAVE;
615
616 return ret;
617 }
618
619 #if 0
620 /*
621 * for rl_icpfunc_t : int fn(char *)
622 */
623 static int
624 icpfunc_wrapper(type, text)
625 int type;
626 char *text;
627 {
628 dSP;
629 int count;
630 int ret;
631
632 ENTER;
633 SAVETMPS;
634
635 PUSHMARK(sp);
636 if (text) {
637 XPUSHs(sv_2mortal(newSVpv(text, 0)));
638 } else {
639 XPUSHs(&PL_sv_undef);
640 }
641 PUTBACK;
642
643 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
644
645 SPAGAIN;
646
647 if (count != 1)
648 croak("Gnu.xs:icpfunc_wrapper: Internal error\n");
649
650 ret = POPi; /* warns unless integer */
651 PUTBACK;
652 FREETMPS;
653 LEAVE;
654 return ret;
655 }
656 #endif
657
658 /*
659 * for rl_cpvfunc_t : (char *)fn(void)
660 */
661 static char *
662 cpvfunc_wrapper(type)
663 int type;
664 {
665 dSP;
666 int count;
667 char *str;
668 SV *svret;
669
670 ENTER;
671 SAVETMPS;
672
673 PUSHMARK(sp);
674 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
675 SPAGAIN;
676
677 if (count != 1)
678 croak("Gnu.xs:cpvfunc_wrapper: Internal error\n");
679
680 svret = POPs;
681 str = SvOK(svret) ? dupstr(SvPV(svret, PL_na)) : NULL;
682 PUTBACK;
683 FREETMPS;
684 LEAVE;
685 return str;
686 }
687
688 /*
689 * for rl_linebuf_func_t : int fn(char *, int)
690 */
691 static int
692 icpintfunc_wrapper(type, text, index)
693 int type;
694 char *text;
695 int index;
696 {
697 dSP;
698 int count;
699 int ret;
700
701 ENTER;
702 SAVETMPS;
703
704 PUSHMARK(sp);
705 if (text) {
706 XPUSHs(sv_2mortal(newSVpv(text, 0)));
707 } else {
708 XPUSHs(&PL_sv_undef);
709 }
710 XPUSHs(sv_2mortal(newSViv(index)));
711 PUTBACK;
712
713 count = perl_call_sv(fn_tbl[type].callback, G_SCALAR);
714
715 SPAGAIN;
716
717 if (count != 1)
718 croak("Gnu.xs:icpintfunc_wrapper: Internal error\n");
719
720 ret = POPi; /* warns unless integer */
721 PUTBACK;
722 FREETMPS;
723 LEAVE;
724 return ret;
725 }
726
727 static int
728 startup_hook_wrapper() { return voidfunc_wrapper(STARTUP_HOOK); }
729 static int
730 event_hook_wrapper() { return voidfunc_wrapper(EVENT_HOOK); }
731
732 static int
733 getc_function_wrapper(fp)
734 PerlIO *fp;
735 {
736 /*
737 * 'PerlIO *fp' is ignored. Use rl_instream instead in the getc_function.
738 * How can I pass 'PerlIO *fp'?
739 */
740 return voidfunc_wrapper(GETC_FN);
741 }
742
743 static void
744 redisplay_function_wrapper() { voidfunc_wrapper(REDISPLAY_FN); }
745
746 /*
747 * call a perl function as rl_completion_entry_function
748 * for rl_compentry_func_t : (char *)fn(const char *, int)
749 */
750
751 static char *
752 completion_entry_function_wrapper(text, state)
753 const char *text;
754 int state;
755 {
756 dSP;
757 int count;
758 SV *match;
759 char *str;
760
761 ENTER;
762 SAVETMPS;
763
764 PUSHMARK(sp);
765 if (text) {
766 XPUSHs(sv_2mortal(newSVpv(text, 0)));
767 } else {
768 XPUSHs(&PL_sv_undef);
769 }
770 XPUSHs(sv_2mortal(newSViv(state)));
771 PUTBACK;
772
773 count = perl_call_sv(fn_tbl[CMP_ENT].callback, G_SCALAR);
774
775 SPAGAIN;
776
777 if (count != 1)
778 croak("Gnu.xs:completion_entry_function_wrapper: Internal error\n");
779
780 match = POPs;
781 str = SvOK(match) ? dupstr(SvPV(match, PL_na)) : NULL;
782
783 PUTBACK;
784 FREETMPS;
785 LEAVE;
786 return str;
787 }
788
789 /*
790 * call a perl function as rl_attempted_completion_function
791 * for rl_completion_func_t : (char **)fn(const char *, int, int)
792 */
793
794 static char **
795 attempted_completion_function_wrapper(text, start, end)
796 char *text;
797 int start;
798 int end;
799 {
800 dSP;
801 int count;
802 char **matches;
803
804 ENTER;
805 SAVETMPS;
806
807 PUSHMARK(sp);
808 if (text) {
809 XPUSHs(sv_2mortal(newSVpv(text, 0)));
810 } else {
811 XPUSHs(&PL_sv_undef);
812 }
813 if (rl_line_buffer) {
814 XPUSHs(sv_2mortal(newSVpv(rl_line_buffer, 0)));
815 } else {
816 XPUSHs(&PL_sv_undef);
817 }
818 XPUSHs(sv_2mortal(newSViv(start)));
819 XPUSHs(sv_2mortal(newSViv(end)));
820 PUTBACK;
821
822 count = perl_call_sv(fn_tbl[ATMPT_COMP].callback, G_ARRAY);
823
824 SPAGAIN;
825
826 /* cf. ignore_some_completions_function_wrapper() */
827 if (count > 0) {
828 int i;
829 int dopack = -1;
830
831 /*
832 * The returned array may contain some undef items.
833 * Pack the array in such case.
834 */
835 matches = (char **)xmalloc (sizeof(char *) * (count + 1));
836 matches[count] = NULL;
837 for (i = count - 1; i >= 0; i--) {
838 SV *v = POPs;
839 if (SvOK(v)) {
840 matches[i] = dupstr(SvPV(v, PL_na));
841 } else {
842 matches[i] = NULL;
843 if (i != 0)
844 dopack = i; /* lowest index of hole */
845 }
846 }
847 /* pack undef items */
848 if (dopack > 0) { /* don't pack matches[0] */
849 int j = dopack;
850 for (i = dopack; i < count; i++) {
851 if (matches[i])
852 matches[j++] = matches[i];
853 }
854 matches[count = j] = NULL;
855 }
856 if (count == 2) { /* only one match */
857 xfree(matches[0]);
858 matches[0] = matches[1];
859 matches[1] = NULL;
860 } else if (count == 1 && !matches[0]) { /* in case of a list of undef */
861 xfree(matches);
862 matches = NULL;
863 }
864 } else {
865 matches = NULL;
866 }
867
868 PUTBACK;
869 FREETMPS;
870 LEAVE;
871
872 return matches;
873 }
874
875 /*
876 * call a perl function as rl_filename_quoting_function
877 * for rl_quote_func_t : (char *)fn(char *, int, char *)
878 */
879
880 static char *
881 filename_quoting_function_wrapper(text, match_type, quote_pointer)
882 char *text;
883 int match_type;
884 char *quote_pointer;
885 {
886 dSP;
887 int count;
888 SV *replacement;
889 char *str;
890
891 ENTER;
892 SAVETMPS;
893
894 PUSHMARK(sp);
895 if (text) {
896 XPUSHs(sv_2mortal(newSVpv(text, 0)));
897 } else {
898 XPUSHs(&PL_sv_undef);
899 }
900 XPUSHs(sv_2mortal(newSViv(match_type)));
901 if (quote_pointer) {
902 XPUSHs(sv_2mortal(newSVpv(quote_pointer, 0)));
903 } else {
904 XPUSHs(&PL_sv_undef);
905 }
906 PUTBACK;
907
908 count = perl_call_sv(fn_tbl[FN_QUOTE].callback, G_SCALAR);
909
910 SPAGAIN;
911
912 if (count != 1)
913 croak("Gnu.xs:filename_quoting_function_wrapper: Internal error\n");
914
915 replacement = POPs;
916 str = SvOK(replacement) ? dupstr(SvPV(replacement, PL_na)) : NULL;
917
918 PUTBACK;
919 FREETMPS;
920 LEAVE;
921 return str;
922 }
923
924 /*
925 * call a perl function as rl_filename_dequoting_function
926 * for rl_dequote_func_t : (char *)fn(char *, int)
927 */
928
929 static char *
930 filename_dequoting_function_wrapper(text, quote_char)
931 char *text;
932 int quote_char;
933 {
934 dSP;
935 int count;
936 SV *replacement;
937 char *str;
938
939 ENTER;
940 SAVETMPS;
941
942 PUSHMARK(sp);
943 if (text) {
944 XPUSHs(sv_2mortal(newSVpv(text, 0)));
945 } else {
946 XPUSHs(&PL_sv_undef);
947 }
948 XPUSHs(sv_2mortal(newSViv(quote_char)));
949 PUTBACK;
950
951 count = perl_call_sv(fn_tbl[FN_DEQUOTE].callback, G_SCALAR);
952
953 SPAGAIN;
954
955 if (count != 1)
956 croak("Gnu.xs:filename_dequoting_function_wrapper: Internal error\n");
957
958 replacement = POPs;
959 str = SvOK(replacement) ? dupstr(SvPV(replacement, PL_na)) : NULL;
960
961 PUTBACK;
962 FREETMPS;
963 LEAVE;
964 return str;
965 }
966
967 /*
968 * call a perl function as rl_char_is_quoted_p
969 */
970
971 static int
972 char_is_quoted_p_wrapper(text, index)
973 char *text;
974 int index;
975 {
976 return icpintfunc_wrapper(CHAR_IS_QUOTEDP, text, index);
977 }
978
979 /*
980 * call a perl function as rl_ignore_some_completions_function
981 * for rl_compignore_func_t : int fn(char **)
982 */
983
984 static void
985 ignore_some_completions_function_wrapper(matches)
986 char **matches;
987 {
988 dSP;
989 int count, i, only_one_match;
990
991 only_one_match = matches[1] == NULL ? 1 : 0;
992
993 ENTER;
994 SAVETMPS;
995
996 PUSHMARK(sp);
997
998 /* matches[0] is the maximal matching substring. So it may NULL, even rest
999 * of matches[] has values. */
1000 if (matches[0]) {
1001 XPUSHs(sv_2mortal(newSVpv(matches[0], 0)));
1002 /* xfree(matches[0]);*/
1003 } else {
1004 XPUSHs(&PL_sv_undef);
1005 }
1006 for (i = 1; matches[i]; i++) {
1007 XPUSHs(sv_2mortal(newSVpv(matches[i], 0)));
1008 xfree(matches[i]);
1009 }
1010 /*xfree(matches);*/
1011 PUTBACK;
1012
1013 count = perl_call_sv(fn_tbl[IGNORE_COMP].callback, G_ARRAY);
1014
1015 SPAGAIN;
1016
1017 if (only_one_match) {
1018 if (count == 0) { /* no match */
1019 xfree(matches[0]);
1020 matches[0] = NULL;
1021 } /* else only one match */
1022 } else if (count > 0) {
1023 int i;
1024 int dopack = -1;
1025
1026 /*
1027 * The returned array may contain some undef items.
1028 * Pack the array in such case.
1029 */
1030 matches[count] = NULL;
1031 for (i = count - 1; i > 0; i--) { /* don't pop matches[0] */
1032 SV *v = POPs;
1033 if (SvOK(v)) {
1034 matches[i] = dupstr(SvPV(v, PL_na));
1035 } else {
1036 matches[i] = NULL;
1037 dopack = i; /* lowest index of undef */
1038 }
1039 }
1040 /* pack undef items */
1041 if (dopack > 0) { /* don't pack matches[0] */
1042 int j = dopack;
1043 for (i = dopack; i < count; i++) {
1044 if (matches[i])
1045 matches[j++] = matches[i];
1046 }
1047 matches[count = j] = NULL;
1048 }
1049 if (count == 1) { /* no match */
1050 xfree(matches[0]);
1051 matches[0] = NULL;
1052 } else if (count == 2) { /* only one match */
1053 xfree(matches[0]);
1054 matches[0] = matches[1];
1055 matches[1] = NULL;
1056 }
1057 } else { /* no match */
1058 xfree(matches[0]);
1059 matches[0] = NULL;
1060 }
1061
1062 PUTBACK;
1063 FREETMPS;
1064 LEAVE;
1065 }
1066
1067 /*
1068 * call a perl function as rl_directory_completion_hook
1069 */
1070
1071 static int
1072 directory_completion_hook_wrapper(textp)
1073 char **textp;
1074 {
1075 return icppfunc_wrapper(DIR_COMP, textp);
1076 }
1077
1078 /*
1079 * call a perl function as history_inhibit_expansion_function
1080 */
1081
1082 static int
1083 history_inhibit_expansion_function_wrapper(text, index)
1084 char *text;
1085 int index;
1086 {
1087 return icpintfunc_wrapper(HIST_INHIBIT_EXP, text, index);
1088 }
1089
1090 static int
1091 pre_input_hook_wrapper() { return voidfunc_wrapper(PRE_INPUT_HOOK); }
1092
1093 #if (RL_VERSION_MAJOR >= 4)
1094 /*
1095 * call a perl function as rl_completion_display_matches_hook
1096 * for rl_compdisp_func_t : void fn(char **, int, int)
1097 */
1098
1099 static void
1100 completion_display_matches_hook_wrapper(matches, len, max)
1101 char **matches;
1102 int len;
1103 int max;
1104 {
1105 dSP;
1106 int i;
1107 AV *av_matches;
1108
1109 /* copy C matches[] array into perl array */
1110 av_matches = newAV();
1111
1112 /* matches[0] is the maximal matching substring. So it may NULL, even rest
1113 * of matches[] has values. */
1114 if (matches[0]) {
1115 av_push(av_matches, sv_2mortal(newSVpv(matches[0], 0)));
1116 } else {
1117 av_push(av_matches, &PL_sv_undef);
1118 }
1119
1120 for (i = 1; matches[i]; i++)
1121 if (matches[i]) {
1122 av_push(av_matches, sv_2mortal(newSVpv(matches[i], 0)));
1123 } else {
1124 av_push(av_matches, &PL_sv_undef);
1125 }
1126
1127 PUSHMARK(sp);
1128 XPUSHs(sv_2mortal(newRV_inc((SV *)av_matches))); /* push reference of array */
1129 XPUSHs(sv_2mortal(newSViv(len)));
1130 XPUSHs(sv_2mortal(newSViv(max)));
1131 PUTBACK;
1132
1133 perl_call_sv(fn_tbl[COMP_DISP_HOOK].callback, G_DISCARD);
1134 }
1135 #else /* (RL_VERSION_MAJOR < 4) */
1136 static void
1137 completion_display_matches_hook_wrapper(matches, len, max)
1138 char **matches;
1139 int len;
1140 int max;
1141 {
1142 /* dummy */
1143 }
1144 #endif /* (RL_VERSION_MAJOR < 4) */
1145
1146 static char *
1147 completion_word_break_hook_wrapper()
1148 {
1149 return cpvfunc_wrapper(COMP_WD_BRK_HOOK);
1150 }
1151
1152 static int
1153 prep_term_function_wrapper(meta_flag)
1154 int meta_flag;
1155 {
1156 return vintfunc_wrapper(PREP_TERM, meta_flag);
1157 }
1158
1159 static int
1160 deprep_term_function_wrapper() { return voidfunc_wrapper(DEPREP_TERM); }
1161
1162 /*
1163 * call a perl function as rl_directory_completion_hook
1164 */
1165 static int
1166 directory_rewrite_hook_wrapper(dirname)
1167 char **dirname;
1168 {
1169 return icppfunc_wrapper(DIR_REWRITE, dirname);
1170 }
1171
1172 /*
1173 * If you need more custom functions, define more funntion_wrapper_xx()
1174 * and add entry on fntbl[].
1175 */
1176
1177 static int function_wrapper PARAMS((int count, int key, int id));
1178
1179 static int fw_00(c, k) int c; int k; { return function_wrapper(c, k, 0); }
1180 static int fw_01(c, k) int c; int k; { return function_wrapper(c, k, 1); }
1181 static int fw_02(c, k) int c; int k; { return function_wrapper(c, k, 2); }
1182 static int fw_03(c, k) int c; int k; { return function_wrapper(c, k, 3); }
1183 static int fw_04(c, k) int c; int k; { return function_wrapper(c, k, 4); }
1184 static int fw_05(c, k) int c; int k; { return function_wrapper(c, k, 5); }
1185 static int fw_06(c, k) int c; int k; { return function_wrapper(c, k, 6); }
1186 static int fw_07(c, k) int c; int k; { return function_wrapper(c, k, 7); }
1187 static int fw_08(c, k) int c; int k; { return function_wrapper(c, k, 8); }
1188 static int fw_09(c, k) int c; int k; { return function_wrapper(c, k, 9); }
1189 static int fw_10(c, k) int c; int k; { return function_wrapper(c, k, 10); }
1190 static int fw_11(c, k) int c; int k; { return function_wrapper(c, k, 11); }
1191 static int fw_12(c, k) int c; int k; { return function_wrapper(c, k, 12); }
1192 static int fw_13(c, k) int c; int k; { return function_wrapper(c, k, 13); }
1193 static int fw_14(c, k) int c; int k; { return function_wrapper(c, k, 14); }
1194 static int fw_15(c, k) int c; int k; { return function_wrapper(c, k, 15); }
1195
1196 static struct fnnode {
1197 Function *wrapper; /* C wrapper function */
1198 SV *pfn; /* Perl function */
1199 } fntbl[] = {
1200 { fw_00, NULL },
1201 { fw_01, NULL },
1202 { fw_02, NULL },
1203 { fw_03, NULL },
1204 { fw_04, NULL },
1205 { fw_05, NULL },
1206 { fw_06, NULL },
1207 { fw_07, NULL },
1208 { fw_08, NULL },
1209 { fw_09, NULL },
1210 { fw_10, NULL },
1211 { fw_11, NULL },
1212 { fw_12, NULL },
1213 { fw_13, NULL },
1214 { fw_14, NULL },
1215 { fw_15, NULL }
1216 };
1217
1218 static int
1219 function_wrapper(count, key, id)
1220 int count;
1221 int key;
1222 int id;
1223 {
1224 dSP;
1225
1226 PUSHMARK(sp);
1227 XPUSHs(sv_2mortal(newSViv(count)));
1228 XPUSHs(sv_2mortal(newSViv(key)));
1229 PUTBACK;
1230
1231 perl_call_sv(fntbl[id].pfn, G_DISCARD);
1232
1233 return 0;
1234 }
1235
1236 static SV *callback_handler_callback = NULL;
1237
1238 static void
1239 callback_handler_wrapper(line)
1240 char *line;
1241 {
1242 dSP;
1243
1244 PUSHMARK(sp);
1245 if (line) {
1246 XPUSHs(sv_2mortal(newSVpv(line, 0)));
1247 } else {
1248 XPUSHs(&PL_sv_undef);
1249 }
1250 PUTBACK;
1251
1252 perl_call_sv(callback_handler_callback, G_DISCARD);
1253 }
1254
1255 /*
1256 * make separate name space for low level XS functions and there methods
1257 */
1258
1259 MODULE = Term::ReadLine::Gnu PACKAGE = Term::ReadLine::Gnu::XS
1260
1261 ########################################################################
1262 #
1263 # Gnu Readline Library
1264 #
1265 ########################################################################
1266 #
1267 # 2.1 Basic Behavior
1268 #
1269
1270 # The function name "readline()" is reserved for a method name.
1271
1272 t_xstr
1273 rl_readline(prompt = NULL)
1274 CONST char * prompt
1275 PROTOTYPE: ;$
1276 CODE:
1277 RETVAL = readline(prompt);
1278 OUTPUT:
1279 RETVAL
1280
1281 #
1282 # 2.4 Readline Convenience Functions
1283 #
1284 #
1285 # 2.4.1 Naming a Function
1286 #
1287 rl_command_func_t *
1288 rl_add_defun(name, fn, key = -1)
1289 const char * name
1290 SV * fn
1291 int key
1292 PROTOTYPE: $$;$
1293 CODE:
1294 {
1295 int i;
1296 int nentry = sizeof(fntbl)/sizeof(struct fnnode);
1297
1298 /* search an empty slot */
1299 for (i = 0; i < nentry; i++)
1300 if (! fntbl[i].pfn)
1301 break;
1302
1303 if (i >= nentry) {
1304 warn("Gnu.xs:rl_add_defun: custom function table is full. The maximum number of custum function is %d.\n",
1305 nentry);
1306 XSRETURN_UNDEF;
1307 }
1308
1309 fntbl[i].pfn = newSVsv(fn);
1310
1311 /* rl_add_defun() always returns 0. */
1312 rl_add_defun(dupstr(name), fntbl[i].wrapper, key);
1313 RETVAL = fntbl[i].wrapper;
1314 }
1315 OUTPUT:
1316 RETVAL
1317
1318 #
1319 # 2.4.2 Selection a Keymap
1320 #
1321 Keymap
1322 rl_make_bare_keymap()
1323 PROTOTYPE:
1324
1325 Keymap
1326 _rl_copy_keymap(map)
1327 Keymap map
1328 PROTOTYPE: $
1329 CODE:
1330 RETVAL = rl_copy_keymap(map);
1331 OUTPUT:
1332 RETVAL
1333
1334 Keymap
1335 rl_make_keymap()
1336 PROTOTYPE:
1337
1338 Keymap
1339 _rl_discard_keymap(map)
1340 Keymap map
1341 PROTOTYPE: $
1342 CODE:
1343 rl_discard_keymap(map);
1344 RETVAL = map;
1345 OUTPUT:
1346 RETVAL
1347
1348 Keymap
1349 rl_get_keymap()
1350 PROTOTYPE:
1351
1352 Keymap
1353 _rl_set_keymap(map)
1354 Keymap map
1355 PROTOTYPE: $
1356 CODE:
1357 rl_set_keymap(map);
1358 RETVAL = map;
1359 OUTPUT:
1360 RETVAL
1361
1362 Keymap
1363 rl_get_keymap_by_name(name)
1364 CONST char * name
1365 PROTOTYPE: $
1366
1367 # Do not free the string returned.
1368 char *
1369 rl_get_keymap_name(map)
1370 Keymap map
1371 PROTOTYPE: $
1372
1373 #
1374 # 2.4.3 Binding Keys
1375 #
1376 int
1377 _rl_bind_key(key, function, map = rl_get_keymap())
1378 int key
1379 rl_command_func_t * function
1380 Keymap map
1381 PROTOTYPE: $$;$
1382 CODE:
1383 RETVAL = rl_bind_key_in_map(key, function, map);
1384 OUTPUT:
1385 RETVAL
1386
1387 #if (RL_VERSION_MAJOR >= 5)
1388 int
1389 _rl_bind_key_if_unbound(key, function, map = rl_get_keymap())
1390 int key
1391 rl_command_func_t * function
1392 Keymap map
1393 PROTOTYPE: $$;$
1394 CODE:
1395 RETVAL = rl_bind_key_if_unbound_in_map(key, function, map);
1396 OUTPUT:
1397 RETVAL
1398
1399 #endif /* (RL_VERSION_MAJOR >= 5) */
1400
1401 int
1402 _rl_unbind_key(key, map = rl_get_keymap())
1403 int key
1404 Keymap map
1405 PROTOTYPE: $;$
1406 CODE:
1407 RETVAL = rl_unbind_key_in_map(key, map);
1408 OUTPUT:
1409 RETVAL
1410
1411 #if (RL_READLINE_VERSION >= 0x0202)
1412
1413 # rl_unbind_function_in_map() and rl_unbind_command_in_map() are introduced
1414 # by readline-2.2.
1415
1416 int
1417 _rl_unbind_function(function, map = rl_get_keymap())
1418 rl_command_func_t * function
1419 Keymap map
1420 PROTOTYPE: $;$
1421 CODE:
1422 RETVAL = rl_unbind_function_in_map(function, map);
1423 OUTPUT:
1424 RETVAL
1425
1426 int
1427 _rl_unbind_command(command, map = rl_get_keymap())
1428 CONST char * command
1429 Keymap map
1430 PROTOTYPE: $;$
1431 CODE:
1432 RETVAL = rl_unbind_command_in_map(command, map);
1433 OUTPUT:
1434 RETVAL
1435
1436 #endif /* (RL_READLINE_VERSION >= 0x0202) */
1437
1438 #if (RL_VERSION_MAJOR >= 5)
1439 int
1440 _rl_bind_keyseq(keyseq, function, map = rl_get_keymap())
1441 const char *keyseq
1442 rl_command_func_t * function
1443 Keymap map
1444 PROTOTYPE: $$;$
1445 CODE:
1446 RETVAL = rl_bind_keyseq_in_map(keyseq, function, map);
1447 OUTPUT:
1448 RETVAL
1449
1450 #endif /* (RL_VERSION_MAJOR >= 5) */
1451
1452 #if (RL_READLINE_VERSION >= 0x0402)
1453 # rl_set_key() is introduced by readline-4.2 and equivalent with
1454 # rl_generic_bind(ISFUNC, keyseq, (char *)function, map).
1455 int
1456 _rl_set_key(keyseq, function, map = rl_get_keymap())
1457 const char * keyseq
1458 rl_command_func_t * function
1459 Keymap map
1460 PROTOTYPE: $$;$
1461 CODE:
1462 RETVAL = rl_set_key(keyseq, function, map);
1463 OUTPUT:
1464 RETVAL
1465
1466 #endif /* (RL_READLINE_VERSION >= 0x0402) */
1467
1468 #if (RL_VERSION_MAJOR >= 5)
1469 int
1470 _rl_bind_keyseq_if_unbound(keyseq, function, map = rl_get_keymap())
1471 const char *keyseq
1472 rl_command_func_t * function
1473 Keymap map
1474 PROTOTYPE: $$;$
1475 CODE:
1476 RETVAL = rl_bind_keyseq_if_unbound_in_map(keyseq, function, map);
1477 OUTPUT:
1478 RETVAL
1479
1480 #endif /* (RL_VERSION_MAJOR >= 5) */
1481
1482 int
1483 _rl_generic_bind_function(keyseq, function, map = rl_get_keymap())
1484 CONST char * keyseq
1485 rl_command_func_t * function
1486 Keymap map
1487 PROTOTYPE: $$;$
1488 CODE:
1489 RETVAL = rl_generic_bind(ISFUNC, keyseq, (char *)function, map);
1490 OUTPUT:
1491 RETVAL
1492
1493 int
1494 _rl_generic_bind_keymap(keyseq, keymap, map = rl_get_keymap())
1495 CONST char * keyseq
1496 Keymap keymap
1497 Keymap map
1498 PROTOTYPE: $$;$
1499 CODE:
1500 RETVAL = rl_generic_bind(ISKMAP, keyseq, (char *)keymap, map);
1501 OUTPUT:
1502 RETVAL
1503
1504 int
1505 _rl_generic_bind_macro(keyseq, macro, map = rl_get_keymap())
1506 CONST char * keyseq
1507 CONST char * macro
1508 Keymap map
1509 PROTOTYPE: $$;$
1510 CODE:
1511 RETVAL = rl_generic_bind(ISMACR, keyseq, dupstr(macro), map);
1512 OUTPUT:
1513 RETVAL
1514
1515 void
1516 rl_parse_and_bind(line)
1517 char * line
1518 PROTOTYPE: $
1519 CODE:
1520 {
1521 char *s = dupstr(line);
1522 rl_parse_and_bind(s); /* Some NULs may be inserted in "s". */
1523 xfree(s);
1524 }
1525
1526 int
1527 rl_read_init_file(filename = NULL)
1528 CONST char * filename
1529 PROTOTYPE: ;$
1530
1531 #
1532 # 2.4.4 Associating Function Names and Bindings
1533 #
1534 int
1535 _rl_call_function(function, count = 1, key = -1)
1536 rl_command_func_t * function
1537 int count
1538 int key
1539 PROTOTYPE: $;$$
1540 CODE:
1541 RETVAL = (*function)(count, key);
1542 OUTPUT:
1543 RETVAL
1544
1545 rl_command_func_t *
1546 rl_named_function(name)
1547 CONST char * name
1548 PROTOTYPE: $
1549
1550 # Do not free the string returned.
1551 const char *
1552 rl_get_function_name(function)
1553 rl_command_func_t * function
1554 PROTOTYPE: $
1555
1556 void
1557 rl_function_of_keyseq(keyseq, map = rl_get_keymap())
1558 CONST char * keyseq
1559 Keymap map
1560 PROTOTYPE: $;$
1561 PPCODE:
1562 {
1563 int type;
1564 rl_command_func_t *p = rl_function_of_keyseq(keyseq, map, &type);
1565 SV *sv;
1566
1567 if (p) {
1568 sv = sv_newmortal();
1569 switch (type) {
1570 case ISFUNC:
1571 sv_setref_pv(sv, "rl_command_func_tPtr", (void*)p);
1572 break;
1573 case ISKMAP:
1574 sv_setref_pv(sv, "Keymap", (void*)p);
1575 break;
1576 case ISMACR:
1577 if (p) {
1578 sv_setpv(sv, (char *)p);
1579 }
1580 break;
1581 default:
1582 warn("Gnu.xs:rl_function_of_keyseq: illegal type `%d'\n", type);
1583 XSRETURN_EMPTY; /* return NULL list */
1584 }
1585 EXTEND(sp, 2);
1586 PUSHs(sv);
1587 PUSHs(sv_2mortal(newSViv(type)));
1588 } else
1589 ; /* return NULL list */
1590 }
1591
1592 void
1593 _rl_invoking_keyseqs(function, map = rl_get_keymap())
1594 rl_command_func_t * function
1595 Keymap map
1596 PROTOTYPE: $;$
1597 PPCODE:
1598 {
1599 char **keyseqs;
1600
1601 keyseqs = rl_invoking_keyseqs_in_map(function, map);
1602
1603 if (keyseqs) {
1604 int i, count;
1605
1606 /* count number of entries */
1607 for (count = 0; keyseqs[count]; count++)
1608 ;
1609
1610 EXTEND(sp, count);
1611 for (i = 0; i < count; i++) {
1612 PUSHs(sv_2mortal(newSVpv(keyseqs[i], 0)));
1613 xfree(keyseqs[i]);
1614 }
1615 xfree((char *)keyseqs);
1616 } else {
1617 /* return null list */
1618 }
1619 }
1620
1621 void
1622 rl_function_dumper(readable = 0)
1623 int readable
1624 PROTOTYPE: ;$
1625
1626 void
1627 rl_list_funmap_names()
1628 PROTOTYPE:
1629
1630 # return list of all function name. (Term::Readline::Gnu specific function)
1631 void
1632 rl_get_all_function_names()
1633 PROTOTYPE:
1634 PPCODE:
1635 {
1636 int i, count;
1637 /* count number of entries */
1638 for (count = 0; funmap[count]; count++)
1639 ;
1640
1641 EXTEND(sp, count);
1642 for (i = 0; i < count; i++) {
1643 PUSHs(sv_2mortal(newSVpv(funmap[i]->name, 0)));
1644 }
1645 }
1646
1647 void
1648 rl_funmap_names()
1649 PROTOTYPE:
1650 PPCODE:
1651 {
1652 const char **funmap;
1653
1654 /* don't free returned memory */
1655 funmap = (const char **)rl_funmap_names();/* cast is for oldies */
1656
1657 if (funmap) {
1658 int i, count;
1659
1660 /* count number of entries */
1661 for (count = 0; funmap[count]; count++)
1662 ;
1663
1664 EXTEND(sp, count);
1665 for (i = 0; i < count; i++) {
1666 PUSHs(sv_2mortal(newSVpv(funmap[i], 0)));
1667 }
1668 } else {
1669 /* return null list */
1670 }
1671 }
1672
1673 #if (RL_READLINE_VERSION >= 0x0402)
1674 # rl_add_funmap_entry() is introduced by readline-4.2.
1675 int
1676 _rl_add_funmap_entry(name, function)
1677 const char * name
1678 rl_command_func_t * function
1679 PROTOTYPE: $$
1680 CODE:
1681 RETVAL = rl_add_funmap_entry(name, function);
1682 OUTPUT:
1683 RETVAL
1684
1685 #endif /* (RL_READLINE_VERSION >= 0x0402) */
1686
1687 #
1688 # 2.4.5 Allowing Undoing
1689 #
1690 int
1691 rl_begin_undo_group()
1692 PROTOTYPE:
1693
1694 int
1695 rl_end_undo_group()
1696 PROTOTYPE:
1697
1698 void
1699 rl_add_undo(what, start, end, text)
1700 int what
1701 int start
1702 int end
1703 char * text
1704 PROTOTYPE: $$$$
1705 CODE:
1706 /* rl_free_undo_list will free the duplicated memory */
1707 rl_add_undo((enum undo_code)what, start, end, dupstr(text));
1708
1709 void
1710 rl_free_undo_list()
1711 PROTOTYPE:
1712
1713 int
1714 rl_do_undo()
1715 PROTOTYPE:
1716
1717 int
1718 rl_modifying(start = 0, end = rl_end)
1719 int start
1720 int end
1721 PROTOTYPE: ;$$
1722
1723 #
1724 # 2.4.6 Redisplay
1725 #
1726 void
1727 rl_redisplay()
1728 PROTOTYPE:
1729
1730 int
1731 rl_forced_update_display()
1732 PROTOTYPE:
1733
1734 int
1735 rl_on_new_line()
1736 PROTOTYPE:
1737
1738 #if (RL_READLINE_VERSION >= 0x0401)
1739 int
1740 rl_on_new_line_with_prompt()
1741 PROTOTYPE:
1742
1743 #endif /* (RL_READLINE_VERSION >= 0x0401) */
1744
1745 int
1746 rl_reset_line_state()
1747 PROTOTYPE:
1748
1749 int
1750 rl_show_char(i)
1751 int i
1752 PROTOTYPE: $
1753
1754 int
1755 _rl_message(text)
1756 const char * text
1757 PROTOTYPE: $
1758 CODE:
1759 RETVAL = rl_message(text);
1760 OUTPUT:
1761 RETVAL
1762
1763 int
1764 rl_crlf()
1765 PROTOTYPE:
1766
1767 int
1768 rl_clear_message()
1769 PROTOTYPE:
1770
1771 void
1772 rl_save_prompt()
1773 PROTOTYPE:
1774
1775 void
1776 rl_restore_prompt()
1777 PROTOTYPE:
1778
1779 int
1780 rl_expand_prompt(prompt)
1781 # should be defined as 'const char *'
1782 char * prompt
1783
1784 #if (RL_READLINE_VERSION >= 0x0402)
1785
1786 int
1787 rl_set_prompt(prompt)
1788 const char * prompt
1789
1790 #endif /* (RL_READLINE_VERSION >= 0x0402) */
1791
1792 #
1793 # 2.4.7 Modifying Text
1794 #
1795 int
1796 rl_insert_text(text)
1797 CONST char * text
1798 PROTOTYPE: $
1799
1800 int
1801 rl_delete_text(start = 0, end = rl_end)
1802 int start
1803 int end
1804 PROTOTYPE: ;$$
1805
1806 t_xstr
1807 rl_copy_text(start = 0, end = rl_end)
1808 int start
1809 int end
1810 PROTOTYPE: ;$$
1811
1812 int
1813 rl_kill_text(start = 0, end = rl_end)
1814 int start
1815 int end
1816 PROTOTYPE: ;$$
1817
1818 # rl_push_macro_input() is documented by readline-4.2 but it has been
1819 # implemented from 2.2.1.
1820
1821 void
1822 rl_push_macro_input(macro)
1823 const char * macro
1824 PROTOTYPE: $
1825 CODE:
1826 rl_push_macro_input(dupstr(macro));
1827
1828 #
1829 # 2.4.8 Character Input
1830 #
1831 int
1832 rl_read_key()
1833 PROTOTYPE:
1834
1835 int
1836 rl_getc(stream)
1837 FILE * stream
1838 PROTOTYPE: $
1839
1840 int
1841 rl_stuff_char(c)
1842 int c
1843 PROTOTYPE: $
1844
1845 #if (RL_VERSION_MAJOR >= 4)
1846
1847 int
1848 rl_execute_next(c)
1849 int c
1850 PROTOTYPE: $
1851
1852 #endif /* (RL_VERSION_MAJOR >= 4) */
1853 #if (RL_READLINE_VERSION >= 0x0402)
1854
1855 int
1856 rl_clear_pending_input()
1857 PROTOTYPE:
1858
1859 int
1860 rl_set_keyboard_input_timeout(usec)
1861 int usec
1862 PROTOTYPE: $
1863
1864 #endif /* (RL_READLINE_VERSION >= 0x0402) */
1865
1866 #
1867 # 2.4.9 Terminal Management
1868 #
1869
1870 #if (RL_VERSION_MAJOR >= 4)
1871
1872 void
1873 rl_prep_terminal(meta_flag)
1874 int meta_flag
1875 PROTOTYPE: $
1876
1877 void
1878 rl_deprep_terminal()
1879 PROTOTYPE:
1880
1881 void
1882 _rl_tty_set_default_bindings(kmap = rl_get_keymap())
1883 Keymap kmap
1884 PROTOTYPE: ;$
1885 CODE:
1886 rl_tty_set_default_bindings(kmap);
1887
1888 #endif /* (RL_VERSION_MAJOR >= 4) */
1889
1890 #if (RL_VERSION_MAJOR >= 5)
1891 void
1892 _rl_tty_unset_default_bindings(kmap = rl_get_keymap())
1893 Keymap kmap
1894 PROTOTYPE: ;$
1895 CODE:
1896 rl_tty_unset_default_bindings(kmap);
1897
1898 #endif /* (RL_VERSION_MAJOR >= 5) */
1899
1900 int
1901 rl_reset_terminal(terminal_name = NULL)
1902 CONST char * terminal_name
1903 PROTOTYPE: ;$
1904
1905 #
1906 # 2.4.10 Utility Functions
1907 #
1908 #if (RL_READLINE_VERSION >= 0x0403)
1909 void
1910 rl_replace_line(text, clear_undo = 0)
1911 const char *text
1912 int clear_undo
1913 PROTOTYPE: $$
1914
1915 #endif /* (RL_READLINE_VERSION >= 0x0403) */
1916
1917 int
1918 rl_initialize()
1919 PROTOTYPE:
1920
1921 int
1922 rl_ding()
1923 PROTOTYPE:
1924
1925 #if (RL_READLINE_VERSION >= 0x0402)
1926
1927 int
1928 rl_alphabetic(c)
1929 int c
1930 PROTOTYPE: $
1931
1932 #endif /* (RL_READLINE_VERSION >= 0x0402) */
1933
1934 #if (RL_VERSION_MAJOR >= 4)
1935
1936 void
1937 rl_display_match_list(pmatches, plen = -1, pmax = -1)
1938 SV * pmatches
1939 int plen
1940 int pmax
1941 PROTOTYPE: $;$$
1942 CODE:
1943 {
1944 unsigned int len, max, i;
1945 STRLEN l;
1946 char **matches;
1947 AV *av_matches;
1948 SV **pvp;
1949
1950 if (SvTYPE(SvRV(pmatches)) != SVt_PVAV) {
1951 warn("Gnu.xs:_rl_display_match_list: the 1st arguments must be a reference of an array\n");
1952 return;
1953 }
1954 av_matches = (AV *)SvRV(ST(0));
1955 /* index zero contains possible match and is ignored */
1956 if ((len = av_len(av_matches) + 1 - 1) == 0)
1957 return;
1958 matches = (char **)xmalloc (sizeof(char *) * (len + 2));
1959 max = 0;
1960 for (i = 1; i <= len; i++) {
1961 pvp = av_fetch(av_matches, i, 0);
1962 if (SvPOKp(*pvp)) {
1963 matches[i] = dupstr(SvPV(*pvp, l));
1964 if (l > max)
1965 max = l;
1966 }
1967 }
1968 matches[len + 1] = NULL;
1969
1970 rl_display_match_list(matches,
1971 plen < 0 ? len : plen,
1972 pmax < 0 ? max : pmax);
1973
1974 for (i = 1; i <= len; i++)
1975 xfree(matches[i]);
1976 xfree(matches);
1977 }
1978
1979 #endif /* (RL_VERSION_MAJOR >= 4) */
1980
1981 #
1982 # 2.4.11 Miscellaneous Functions
1983 #
1984
1985 # rl_macro_bind() is documented by readline-4.2 but it has been implemented
1986 # from 2.2.1.
1987 # It is equivalent with
1988 # rl_generic_bind(ISMACR, keyseq, (char *)macro_keys, map).
1989 int
1990 _rl_macro_bind(keyseq, macro, map = rl_get_keymap())
1991 CONST char * keyseq
1992 CONST char * macro
1993 Keymap map
1994 PROTOTYPE: $$;$
1995 CODE:
1996 RETVAL = rl_macro_bind(keyseq, macro, map);
1997 OUTPUT:
1998 RETVAL
1999
2000 # rl_macro_dumper is documented by Readline 4.2,
2001 # but have been implemented for 2.2.1.
2002
2003 void
2004 rl_macro_dumper(readable = 0)
2005 int readable
2006 PROTOTYPE: ;$
2007
2008 # rl_variable_bind() is documented by readline-4.2 but it has been implemented
2009 # from 2.2.1.
2010
2011 int
2012 rl_variable_bind(name, value)
2013 CONST char * name
2014 CONST char * value
2015 PROTOTYPE: $$
2016
2017 # rl_variable_dumper is documented by Readline 4.2,
2018 # but have been implemented for 2.2.1.
2019
2020 void
2021 rl_variable_dumper(readable = 0)
2022 int readable
2023 PROTOTYPE: ;$
2024
2025 #if (RL_READLINE_VERSION >= 0x0402)
2026
2027 int
2028 rl_set_paren_blink_timeout(usec)
2029 int usec
2030 PROTOTYPE: $
2031
2032 #endif /* (RL_READLINE_VERSION >= 0x0402) */
2033
2034 # rl_get_termcap() is documented by readline-4.2 but it has been implemented
2035 # from 2.2.1.
2036
2037 # Do not free the string returned.
2038 char *
2039 rl_get_termcap(cap)
2040 CONST char * cap
2041 PROTOTYPE: $
2042
2043 #
2044 # 2.4.12 Alternate Interface
2045 #
2046
2047 void
2048 rl_callback_handler_install(prompt, lhandler)
2049 const char * prompt
2050 SV * lhandler
2051 PROTOTYPE: $$
2052 CODE:
2053 {
2054 static char *cb_prompt = NULL;
2055 int len = strlen(prompt) + 1;
2056
2057 /* The value of prompt may be used after return from this routine. */
2058 if (cb_prompt) {
2059 Safefree(cb_prompt);
2060 }
2061 New(0, cb_prompt, len, char);
2062 Copy(prompt, cb_prompt, len, char);
2063
2064 /*
2065 * Don't remove braces. The definition of SvSetSV() of
2066 * Perl 5.003 has a problem.
2067 */
2068 if (callback_handler_callback) {
2069 SvSetSV(callback_handler_callback, lhandler);
2070 } else {
2071 callback_handler_callback = newSVsv(lhandler);
2072 }
2073
2074 rl_callback_handler_install(cb_prompt, callback_handler_wrapper);
2075 }
2076
2077 void
2078 rl_callback_read_char()
2079 PROTOTYPE:
2080
2081 void
2082 rl_callback_handler_remove()
2083 PROTOTYPE:
2084
2085 #
2086 # 2.5 Readline Signal Handling
2087 #
2088
2089 void
2090 rl_cleanup_after_signal()
2091 PROTOTYPE:
2092
2093 void
2094 rl_free_line_state()
2095 PROTOTYPE:
2096
2097 void
2098 rl_reset_after_signal()
2099 PROTOTYPE:
2100
2101 void
2102 rl_resize_terminal()
2103 PROTOTYPE:
2104
2105 #if (RL_READLINE_VERSION >= 0x0402)
2106
2107 void
2108 rl_set_screen_size(rows, cols)
2109 int rows
2110 int cols
2111 PROTOTYPE: $$
2112
2113 void
2114 rl_get_screen_size()
2115 PROTOTYPE:
2116 PPCODE:
2117 {
2118 int rows, cols;
2119 rl_get_screen_size(&rows, &cols);
2120 EXTEND(sp, 2);
2121 PUSHs(sv_2mortal(newSViv(rows)));
2122 PUSHs(sv_2mortal(newSViv(cols)));
2123 }
2124
2125 #endif /* (RL_READLINE_VERSION >= 0x0402) */
2126
2127 int
2128 rl_set_signals()
2129 PROTOTYPE:
2130
2131 int
2132 rl_clear_signals()
2133 PROTOTYPE:
2134
2135 #
2136 # 2.6 Custom Completers
2137 #
2138
2139 int
2140 rl_complete_internal(what_to_do = TAB)
2141 int what_to_do
2142 PROTOTYPE: ;$
2143
2144 #if (RL_READLINE_VERSION >= 0x0403)
2145 int
2146 _rl_completion_mode(function)
2147 rl_command_func_t * function
2148 PROTOTYPE: $
2149 CODE:
2150 RETVAL = rl_completion_mode(function);
2151 OUTPUT:
2152 RETVAL
2153
2154 #endif /* (RL_READLINE_VERSION >= 0x0403) */
2155
2156 void
2157 rl_completion_matches(text, fn = NULL)
2158 const char * text
2159 SV * fn
2160 PROTOTYPE: $;$
2161 PPCODE:
2162 {
2163 char **matches;
2164
2165 if (SvTRUE(fn)) {
2166 /* use completion_entry_function temporarily */
2167 Function *rlfunc_save = *(fn_tbl[CMP_ENT].rlfuncp);
2168 SV *callback_save = fn_tbl[CMP_ENT].callback;
2169 fn_tbl[CMP_ENT].callback = newSVsv(fn);
2170
2171 matches = rl_completion_matches(text,
2172 completion_entry_function_wrapper);
2173
2174 SvREFCNT_dec(fn_tbl[CMP_ENT].callback);
2175 fn_tbl[CMP_ENT].callback = callback_save;
2176 *(fn_tbl[CMP_ENT].rlfuncp) = rlfunc_save;
2177 } else
2178 matches = rl_completion_matches(text, NULL);
2179
2180 /*
2181 * Without the next line the Perl internal stack is broken
2182 * under some condition. Perl bug or undocumented feature
2183 * !!!?
2184 */
2185 SPAGAIN; sp -= 2;
2186
2187 if (matches) {
2188 int i, count;
2189
2190 /* count number of entries */
2191 for (count = 0; matches[count]; count++)
2192 ;
2193
2194 EXTEND(sp, count);
2195 for (i = 0; i < count; i++) {
2196 PUSHs(sv_2mortal(newSVpv(matches[i], 0)));
2197 xfree(matches[i]);
2198 }
2199 xfree((char *)matches);
2200 } else {
2201 /* return null list */
2202 }
2203 }
2204
2205 t_xstr
2206 rl_filename_completion_function(text, state)
2207 const char * text
2208 int state
2209 PROTOTYPE: $$
2210
2211 t_xstr
2212 rl_username_completion_function(text, state)
2213 const char * text
2214 int state
2215 PROTOTYPE: $$
2216
2217
2218 ########################################################################
2219 #
2220 # Gnu History Library
2221 #
2222 ########################################################################
2223
2224 #
2225 # 2.3.1 Initializing History and State Management
2226 #
2227 void
2228 using_history()
2229 PROTOTYPE:
2230
2231 # history_get_history_state() and history_set_history_state() are useless
2232 # and too dangerous to be used in Perl code
2233 # void
2234 # history_get_history_state()
2235 # PROTOTYPE:
2236 # PPCODE:
2237 # {
2238 # HISTORY_STATE *state;
2239 #
2240 # state = history_get_history_state();
2241 # EXTEND(sp, 4);
2242 # PUSHs(sv_2mortal(newSViv(state->offset)));
2243 # PUSHs(sv_2mortal(newSViv(state->length)));
2244 # PUSHs(sv_2mortal(newSViv(state->size)));
2245 # PUSHs(sv_2mortal(newSViv(state->flags)));
2246 # xfree((char *)state);
2247 # }
2248
2249 #
2250 # 2.3.2 History List Management
2251 #
2252
2253 void
2254 add_history(string)
2255 CONST char * string
2256 PROTOTYPE: $
2257
2258 #if (RL_VERSION_MAJOR >= 5)
2259 void
2260 add_history_time(string)
2261 CONST char * string
2262 PROTOTYPE: $
2263
2264 #endif /* (RL_VERSION_MAJOR >= 5) */
2265
2266 HIST_ENTRY *
2267 remove_history(which)
2268 int which
2269 PROTOTYPE: $
2270 OUTPUT:
2271 RETVAL
2272 CLEANUP:
2273 if (RETVAL) {
2274 xfree(RETVAL->line);
2275 #if (RL_VERSION_MAJOR >= 5)
2276 xfree(RETVAL->timestamp);
2277 #endif /* (RL_VERSION_MAJOR >= 5) */
2278 xfree(RETVAL->data);
2279 xfree((char *)RETVAL);
2280 }
2281
2282 # free_history_entry() is introduced by GNU Readline Library 5.0.
2283 # Since Term::ReadLine::Gnu does not support the member 'data' of HIST_ENTRY
2284 # structure, remove_history() covers it.
2285
2286 # The 3rd parameter (histdata_t) is not supported. Does anyone use it?
2287 HIST_ENTRY *
2288 replace_history_entry(which, line)
2289 int which
2290 CONST char * line
2291 PROTOTYPE: $$
2292 CODE:
2293 RETVAL = replace_history_entry(which, line, (char *)NULL);
2294 OUTPUT:
2295 RETVAL
2296 CLEANUP:
2297 if (RETVAL) {
2298 xfree(RETVAL->line);
2299 #if (RL_VERSION_MAJOR >= 5)
2300 xfree(RETVAL->timestamp);
2301 #endif /* (RL_VERSION_MAJOR >= 5) */
2302 xfree(RETVAL->data);
2303 xfree((char *)RETVAL);
2304 }
2305
2306 void
2307 clear_history()
2308 PROTOTYPE:
2309
2310 int
2311 stifle_history(i)
2312 SV * i
2313 PROTOTYPE: $
2314 CODE:
2315 {
2316 if (SvOK(i)) {
2317 int max = SvIV(i);
2318 stifle_history(max);
2319 RETVAL = max;
2320 } else {
2321 RETVAL = unstifle_history();
2322 }
2323 }
2324 OUTPUT:
2325 RETVAL
2326
2327 int
2328 unstifle_history()
2329 PROTOTYPE:
2330
2331 int
2332 history_is_stifled()
2333 PROTOTYPE:
2334
2335 #
2336 # 2.3.3 Information about the History List
2337 #
2338
2339 # history_list() is implemented as a perl function in Gnu.pm.
2340
2341 int
2342 where_history()
2343 PROTOTYPE:
2344
2345 HIST_ENTRY *
2346 current_history()
2347 PROTOTYPE:
2348
2349 HIST_ENTRY *
2350 history_get(offset)
2351 int offset
2352 PROTOTYPE: $
2353
2354 #if (RL_VERSION_MAJOR >= 5)
2355 # To keep compatibility, I cannot make a function whose argument
2356 # is "HIST_ENTRY *".
2357 time_t
2358 history_get_time(offset)
2359 int offset
2360 PROTOTYPE: $
2361 CODE:
2362 {
2363 HIST_ENTRY *he = history_get(offset);
2364 if (he)
2365 RETVAL = history_get_time(he);
2366 else
2367 RETVAL = 0;
2368 }
2369 OUTPUT:
2370 RETVAL
2371
2372 #endif /* (RL_VERSION_MAJOR >= 5) */
2373
2374 int
2375 history_total_bytes()
2376 PROTOTYPE:
2377
2378 #
2379 # 2.3.4 Moving Around the History List
2380 #
2381 int
2382 history_set_pos(pos)
2383 int pos
2384 PROTOTYPE: $
2385
2386 HIST_ENTRY *
2387 previous_history()
2388 PROTOTYPE:
2389
2390 HIST_ENTRY *
2391 next_history()
2392 PROTOTYPE:
2393
2394 #
2395 # 2.3.5 Searching the History List
2396 #
2397 int
2398 history_search(string, direction = -1)
2399 CONST char * string
2400 int direction
2401 PROTOTYPE: $;$
2402
2403 int
2404 history_search_prefix(string, direction = -1)
2405 CONST char * string
2406 int direction
2407 PROTOTYPE: $;$
2408
2409 int
2410 history_search_pos(string, direction = -1, pos = where_history())
2411 CONST char * string
2412 int direction
2413 int pos
2414 PROTOTYPE: $;$$
2415
2416 #
2417 # 2.3.6 Managing the History File
2418 #
2419 int
2420 read_history_range(filename = NULL, from = 0, to = -1)
2421 CONST char * filename
2422 int from
2423 int to
2424 PROTOTYPE: ;$$$
2425
2426 int
2427 write_history(filename = NULL)
2428 CONST char * filename
2429 PROTOTYPE: ;$
2430
2431 int
2432 append_history(nelements, filename = NULL)
2433 int nelements
2434 CONST char * filename
2435 PROTOTYPE: $;$
2436
2437 int
2438 history_truncate_file(filename = NULL, nlines = 0)
2439 CONST char * filename
2440 int nlines
2441 PROTOTYPE: ;$$
2442
2443 #
2444 # 2.3.7 History Expansion
2445 #
2446 void
2447 history_expand(line)
2448 # should be defined as 'const char *'
2449 char * line
2450 PROTOTYPE: $
2451 PPCODE:
2452 {
2453 char *expansion;
2454 int result;
2455
2456 result = history_expand(line, &expansion);
2457 EXTEND(sp, 2);
2458 PUSHs(sv_2mortal(newSViv(result)));
2459 PUSHs(sv_2mortal(newSVpv(expansion, 0)));
2460 xfree(expansion);
2461 }
2462
2463 void
2464 _get_history_event(string, cindex, qchar = 0)
2465 CONST char * string
2466 int cindex
2467 int qchar
2468 PROTOTYPE: $$;$
2469 PPCODE:
2470 {
2471 char *text;
2472
2473 text = get_history_event(string, &cindex, qchar);
2474 EXTEND(sp, 2);
2475 if (text) { /* don't free `text' */
2476 PUSHs(sv_2mortal(newSVpv(text, 0)));
2477 } else {
2478 PUSHs(&PL_sv_undef);
2479 }
2480 PUSHs(sv_2mortal(newSViv(cindex)));
2481 }
2482
2483 void
2484 history_tokenize(text)
2485 CONST char * text
2486 PROTOTYPE: $
2487 PPCODE:
2488 {
2489 char **tokens;
2490
2491 tokens = history_tokenize(text);
2492 if (tokens) {
2493 int i, count;
2494
2495 /* count number of entries */
2496 for (count = 0; tokens[count]; count++)
2497 ;
2498
2499 EXTEND(sp, count);
2500 for (i = 0; i < count; i++) {
2501 PUSHs(sv_2mortal(newSVpv(tokens[i], 0)));
2502 xfree(tokens[i]);
2503 }
2504 xfree((char *)tokens);
2505 } else {
2506 /* return null list */
2507 }
2508 }
2509
2510 #define DALLAR '$' /* define for xsubpp bug */
2511
2512 t_xstr
2513 _history_arg_extract(line, first = 0 , last = DALLAR)
2514 CONST char * line
2515 int first
2516 int last
2517 PROTOTYPE: $;$$
2518 CODE:
2519 RETVAL = history_arg_extract(first, last, line);
2520 OUTPUT:
2521 RETVAL
2522
2523
2524 #
2525 # GNU Readline/History Library Variable Access Routines
2526 #
2527
2528 MODULE = Term::ReadLine::Gnu PACKAGE = Term::ReadLine::Gnu::Var
2529
2530 void
2531 _rl_store_str(pstr, id)
2532 const char * pstr
2533 int id
2534 PROTOTYPE: $$
2535 CODE:
2536 {
2537 size_t len;
2538
2539 ST(0) = sv_newmortal();
2540 if (id < 0 || id >= sizeof(str_tbl)/sizeof(struct str_vars)) {
2541 warn("Gnu.xs:_rl_store_str: Illegal `id' value: `%d'", id);
2542 XSRETURN_UNDEF;
2543 }
2544
2545 if (str_tbl[id].read_only) {
2546 warn("Gnu.xs:_rl_store_str: store to read only variable");
2547 XSRETURN_UNDEF;
2548 }
2549
2550 /*
2551 * Use xmalloc() and xfree() instead of New() and Safefree(),
2552 * because this block may be reallocated by the GNU Readline Library.
2553 */
2554 if (str_tbl[id].accessed && *str_tbl[id].var) {
2555 /*
2556 * First time a variable is used by this routine,
2557 * it may be a static area. So it cannot be freed.
2558 */
2559 xfree(*str_tbl[id].var);
2560 *str_tbl[id].var = NULL;
2561 }
2562 str_tbl[id].accessed = 1;
2563
2564 len = strlen(pstr) + 1;
2565 *str_tbl[id].var = xmalloc(len);
2566 Copy(pstr, *str_tbl[id].var, len, char);
2567
2568 /* return variable value */
2569 if (*str_tbl[id].var) {
2570 sv_setpv(ST(0), *str_tbl[id].var);
2571 }
2572 }
2573
2574 void
2575 _rl_store_rl_line_buffer(pstr)
2576 const char * pstr
2577 PROTOTYPE: $
2578 CODE:
2579 {
2580 size_t len;
2581
2582 ST(0) = sv_newmortal();
2583 if (pstr) {
2584 len = strlen(pstr);
2585
2586 /*
2587 * Old manual did not document this function, but can be
2588 * used.
2589 */
2590 rl_extend_line_buffer(len + 1);
2591
2592 Copy(pstr, rl_line_buffer, len + 1, char);
2593 /* rl_line_buffer is not NULL here */
2594 sv_setpv(ST(0), rl_line_buffer);
2595
2596 /* fix rl_end and rl_point */
2597 rl_end = len;
2598 if (rl_point > len)
2599 rl_point = len;
2600 }
2601 }
2602
2603 void
2604 _rl_fetch_str(id)
2605 int id
2606 PROTOTYPE: $
2607 CODE:
2608 {
2609 ST(0) = sv_newmortal();
2610 if (id < 0 || id >= sizeof(str_tbl)/sizeof(struct str_vars)) {
2611 warn("Gnu.xs:_rl_fetch_str: Illegal `id' value: `%d'", id);
2612 } else {
2613 if (*(str_tbl[id].var)) {
2614 sv_setpv(ST(0), *(str_tbl[id].var));
2615 }
2616 }
2617 }
2618
2619 void
2620 _rl_store_int(pint, id)
2621 int pint
2622 int id
2623 PROTOTYPE: $$
2624 CODE:
2625 {
2626 ST(0) = sv_newmortal();
2627 if (id < 0 || id >= sizeof(int_tbl)/sizeof(struct int_vars)) {
2628 warn("Gnu.xs:_rl_store_int: Illegal `id' value: `%d'", id);
2629 XSRETURN_UNDEF;
2630 }
2631
2632 if (int_tbl[id].read_only) {
2633 warn("Gnu.xs:_rl_store_int: store to read only variable");
2634 XSRETURN_UNDEF;
2635 }
2636
2637 /* set C variable */
2638 if (int_tbl[id].charp)
2639 *((char *)(int_tbl[id].var)) = (char)pint;
2640 else
2641 *(int_tbl[id].var) = pint;
2642
2643 /* return variable value */
2644 sv_setiv(ST(0), pint);
2645 }
2646
2647 void
2648 _rl_fetch_int(id)
2649 int id
2650 PROTOTYPE: $
2651 CODE:
2652 {
2653 ST(0) = sv_newmortal();
2654 if (id < 0 || id >= sizeof(int_tbl)/sizeof(struct int_vars)) {
2655 warn("Gnu.xs:_rl_fetch_int: Illegal `id' value: `%d'", id);
2656 /* return undef */
2657 } else {
2658 sv_setiv(ST(0),
2659 int_tbl[id].charp ? (int)*((char *)(int_tbl[id].var))
2660 : *(int_tbl[id].var));
2661 }
2662 }
2663
2664 PerlIO *
2665 _rl_store_iostream(stream, id)
2666 PerlIO *stream
2667 int id
2668 PROTOTYPE: $$
2669 CODE:
2670 {
2671 switch (id) {
2672 case 0:
2673 if (instreamPIO != NULL)
2674 PerlIO_releaseFILE(instreamPIO, rl_instream);
2675 rl_instream = PerlIO_findFILE(stream);
2676 RETVAL = instreamPIO = stream;
2677 break;
2678 case 1:
2679 if (outstreamPIO != NULL)
2680 PerlIO_releaseFILE(outstreamPIO, rl_outstream);
2681 rl_outstream = PerlIO_findFILE(stream);
2682 RETVAL = outstreamPIO = stream;
2683 #ifdef __CYGWIN__
2684 {
2685 /* Cygwin b20.1 library converts NL to CR-NL
2686 automatically. But it does not do it on a file
2687 stream made by Perl. Set terminal attribute
2688 explicitly */
2689 struct termios tio;
2690 tcgetattr(fileno(rl_outstream), &tio);
2691 tio.c_iflag |= ICRNL;
2692 tio.c_oflag |= ONLCR;
2693 tcsetattr(fileno(rl_outstream), TCSADRAIN, &tio);
2694 }
2695 #endif /* __CYGWIN__ */
2696 break;
2697 default:
2698 warn("Gnu.xs:_rl_store_iostream: Illegal `id' value: `%d'", id);
2699 XSRETURN_UNDEF;
2700 break;
2701 }
2702 }
2703 OUTPUT:
2704 RETVAL
2705
2706 PerlIO *
2707 _rl_fetch_iostream(id)
2708 int id
2709 PROTOTYPE: $
2710 CODE:
2711 {
2712 switch (id) {
2713 case 0:
2714 if (instreamPIO == NULL)
2715 RETVAL = instreamPIO = PerlIO_importFILE(rl_instream, NULL);
2716 else
2717 RETVAL = instreamPIO;
2718 break;
2719 case 1:
2720 if (outstreamPIO == NULL)
2721 RETVAL = outstreamPIO = PerlIO_importFILE(rl_outstream, NULL);
2722 else
2723 RETVAL = outstreamPIO;
2724 break;
2725 default:
2726 warn("Gnu.xs:_rl_fetch_iostream: Illegal `id' value: `%d'", id);
2727 XSRETURN_UNDEF;
2728 break;
2729 }
2730 }
2731 OUTPUT:
2732 RETVAL
2733
2734 Keymap
2735 _rl_fetch_keymap(id)
2736 int id
2737 PROTOTYPE: $
2738 CODE:
2739 {
2740 switch (id) {
2741 case 0:
2742 RETVAL = rl_executing_keymap;
2743 break;
2744 case 1:
2745 RETVAL = rl_binding_keymap;
2746 break;
2747 default:
2748 warn("Gnu.xs:_rl_fetch_keymap: Illegal `id' value: `%d'", id);
2749 XSRETURN_UNDEF;
2750 break;
2751 }
2752 }
2753 OUTPUT:
2754 RETVAL
2755
2756 void
2757 _rl_store_function(fn, id)
2758 SV * fn
2759 int id
2760 PROTOTYPE: $$
2761 CODE:
2762 {
2763 /*
2764 * If "fn" is undef, default value of the GNU Readline
2765 * Library is set.
2766 */
2767 ST(0) = sv_newmortal();
2768 if (id < 0 || id >= sizeof(fn_tbl)/sizeof(struct fn_vars)) {
2769 warn("Gnu.xs:_rl_store_function: Illegal `id' value: `%d'", id);
2770 XSRETURN_UNDEF;
2771 }
2772
2773 if (SvTRUE(fn)) {
2774 /*
2775 * Don't remove braces. The definition of SvSetSV() of
2776 * Perl 5.003 has a problem.
2777 */
2778 if (fn_tbl[id].callback) {
2779 SvSetSV(fn_tbl[id].callback, fn);
2780 } else {
2781 fn_tbl[id].callback = newSVsv(fn);
2782 }
2783 *(fn_tbl[id].rlfuncp) = fn_tbl[id].wrapper;
2784 } else {
2785 if (fn_tbl[id].callback) {
2786 SvSetSV(fn_tbl[id].callback, &PL_sv_undef);
2787 }
2788 *(fn_tbl[id].rlfuncp) = fn_tbl[id].defaultfn;
2789 }
2790
2791 /* return variable value */
2792 sv_setsv(ST(0), fn);
2793 }
2794
2795 void
2796 _rl_fetch_function(id)
2797 int id
2798 PROTOTYPE: $
2799 CODE:
2800 {
2801 ST(0) = sv_newmortal();
2802 if (id < 0 || id >= sizeof(fn_tbl)/sizeof(struct fn_vars)) {
2803 warn("Gnu.xs:_rl_fetch_function: Illegal `id' value: `%d'", id);
2804 /* return undef */
2805 } else if (fn_tbl[id].callback && SvTRUE(fn_tbl[id].callback)) {
2806 sv_setsv(ST(0), fn_tbl[id].callback);
2807 }
2808 }
2809
2810 Function *
2811 _rl_fetch_last_func()
2812 PROTOTYPE:
2813 CODE:
2814 RETVAL = rl_last_func;
2815 OUTPUT:
2816 RETVAL
2817
2818 MODULE = Term::ReadLine::Gnu PACKAGE = Term::ReadLine::Gnu::XS
2819
2820 void
2821 tgetstr(id)
2822 const char * id
2823 PROTOTYPE: $
2824 CODE:
2825 ST(0) = sv_newmortal();
2826 if (id) {
2827 /*
2828 * The magic number `2032' is derived from bash
2829 * terminal.c:_rl_init_terminal_io().
2830 */
2831 char buffer[2032];
2832 char *bp = buffer;
2833 char *t;
2834 t = tgetstr(id, &bp); /* don't free returned string */
2835 if (t) {
2836 char buf[2032];
2837 /* call tputs() to apply padding information */
2838 tputs_ptr = buf;
2839 tputs(t, 1, tputs_char);
2840 *tputs_ptr = '\0';
2841 sv_setpv(ST(0), buf);
2842 }
2843 }
2844
2845 #
2846 # Local Variables:
2847 # c-default-style: "gnu"
2848 # End:
2849 #
+119
-0
INSTALL less more
0 -*- Indented-text -*-
1 # $Id: INSTALL,v 1.21 2002-07-27 23:20:05-05 hiroo Exp $
2
3 1. How to Install Term::ReadLine::Gnu
4
5 You need the GNU Readline library installed. Except for this,
6 you can install this module by the standard method, i.e.
7
8 perl Makefile.PL; make install
9
10 1.1 Install GNU Readline library 2.1 or later and their header files.
11
12 See the section `How to Install GNU Readline Library'.
13
14 1.2 Make and install
15
16 % perl Makefile.PL [--prefix=...] [--includedir=...] [--libdir=...]
17 % make
18 % make test
19 % make install
20
21 If you have installed the GNU Readline Library
22 (libreadline.{a,so} and readline/readline.h, etc.) on
23 directories for which your perl is not configured to search
24 (refer the value of ccflags and libpath in the output of `perl
25 -V'), specify the paths as follows;
26
27 % perl Makefile.PL --includedir=/mydir/include --libdir=/mydir/lib
28
29 This example is equivalent to the following;
30
31 % perl Makefile.PL --prefix=/mydir
32
33 If you are not an administrator and cannot install Perl module
34 in your system directory, try
35 perldoc perlfaq8
36 and see the section 'How do I keep my own module/library
37 directory?' (This section is found in the Perl 5.6
38 documentation).
39
40 1.3 Trouble Shooting
41
42 If you have any trouble when using or installing this module,
43 please let me (hiroo.hayashi@computer.org) know by E-Mail. It
44 may help other people who have the same problem. I'm sorry
45 that I cannot watch all articles on comp.lang.perl.modules.
46
47 When you report your trouble, be sure to send me the following
48 information;
49 o result of `perl -V'
50 o compiler you used to compile the GNU Readline Library
51 (libreadline.a).
52 o terminal emulator which you are using
53 o result of `echo $TERM`
54
55 2. How to Install GNU Readline Library
56
57 Now this module supports only GNU Readline Library 2.1 and
58 later. Executing `perl Makefile.PL` detects which version of
59 the GNU Readline Library is already installed and warns you if
60 you have the unsupported version.
61
62 In the following example, the install prefix directory is
63 `/usr/local/gnu'.
64
65 You can specify any directory for the GNU Readline library and
66 its header files, by editing `LIBS' and/or `INC' section in
67 Makefile.PL.
68
69 2.1. Install
70
71 readline-2.2.tar.gz has some bugs, so I strongly recommend you
72 to use readline-2.2.1.tar.gz and/or later instead.
73
74 1. get and extract readline-XX.tar.gz
75
76 2. configure
77 % ./configure --prefix=/usr/local/gnu
78 3. make and install
79 % make install
80
81 If you have any reason in which use must use one of the follows;
82 readline-2.1
83 libreadline.a in bash-2.0.tar.gz
84 Cygwin b20.1
85 see INSTALL file which is included in Term-ReadLine-Gnu-1.11.
86
87 2.2 Shared Library
88
89 If you want to build it as shared library, use readline-4.0
90 (or later). Type `make shared' instead of `make' to build
91 shared library.
92
93 You HAVE TO build the library as shared library on the
94 following OSs;
95 HPUX
96
97 You DON'T HAVE TO and may build the library as shared library
98 on the following OSs;
99 GNU/Linux 2.x
100 SunOS 4.x, 5.x
101 AIX 4.1.x
102 Cygwin 20.x
103
104 # Please let me know on your experience on others OSs.
105
106 2.3 Multibyte Character (Japanese character) Handling
107
108 # readline-4.3 on some system has multibyte support. If your
109 # system supports it, ignore this section.
110
111 Since the GNU Readline Library is 8 bit clean, I use Japanese
112 characters without any patch. But I have to hit Backspace key
113 twice to erase a Japanese character.
114
115 If you are using EUC Japanese charactor try to use
116 Gnu/euc_jp.pm module.
117
118 EOF
+25
-0
MANIFEST less more
0 Gnu.pm The GNU Readline extension Perl module
1 Gnu.xs The GNU Readline extension external subroutines
2 Gnu/XS.pm
3 Gnu/euc_jp.pm
4 INSTALL Installtion instructions
5 MANIFEST This list of files
6 Makefile.PL The GNU Readline extension makefile writer
7 README The Instructions
8 eg/perlsh A powerful calculator
9 eg/fileman A short completion example
10 eg/pftp An ftp client with the GNU Readline support
11 eg/ptksh+ Simple perl/Tk shell which demonstrates the callback functions
12 ppport.h Perl/Pollution/Portability Version 1.0007
13 t/comptest/0123 A file for t/readline.t
14 t/comptest/012345 A file for t/readline.t
15 t/comptest/023456 A file for t/readline.t
16 t/comptest/README A file for t/readline.t
17 t/comptest/a_b A file for t/readline.t
18 t/button.pl a test script for t/callback.t
19 t/callback.t a test script for the GNU Readline callback function
20 t/history.t a test script for the GNU History Library function
21 t/inputrc A file for t/readline.t
22 t/readline.t a test script for the GNU Readline extension
23 typemap The GNU Readline extension interface types
24 META.yml Module meta-data (added by MakeMaker)
+10
-0
META.yml less more
0 # http://module-build.sourceforge.net/META-spec.html
1 #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
2 name: Term-ReadLine-Gnu
3 version: 1.15
4 version_from: Gnu.pm
5 installdirs: site
6 requires:
7
8 distribution_type: module
9 generated_by: ExtUtils::MakeMaker version 6.17
+190
-0
Makefile.PL less more
0 #
1 # Makefile.PL for Term::ReadLine::Gnu
2 #
3 # $Id: Makefile.PL,v 1.27 2003-03-16 20:26:25-05 hiroo Exp $
4 #
5 # Copyright (c) 2003 Hiroo Hayashi. All rights reserved.
6 # <hiroo.hayashi@computer.org>
7 #
8 # This program is free software; you can redistribute it and/or
9 # modify it under the same terms as Perl itself.
10 #
11 # OS/2 support is contributed by Ilya Zakharevich.
12 # <ilya@math.ohio-state.edu>
13 #
14 # Usage: perl Makefile.PL [--prefix=...] [--includedir=...] [--libdir=...]
15 # [OPTIMIZE=...]
16 #
17 # Read INSTALL for more details.
18 ########################################################################
19 use strict;
20 use ExtUtils::MakeMaker;
21 use Config;
22 use Getopt::Long;
23
24 my ($defs, $libs, $lddflags, $RLLIB, $RLINC);
25
26 $defs = ($Config{strings} =~ m|/string.h$|) ? '-DHAVE_STRING_H' : '';
27
28 # Parse command line to specify paths for the GNU Readline Library
29 {
30 my ($prefix, $libdir, $incdir);
31 GetOptions("prefix=s" => \$prefix,
32 "libdir=s" => \$libdir,
33 "includedir=s" => \$incdir);
34 $RLLIB = defined $libdir
35 ? "-L$libdir" : (defined $prefix ? "-L$prefix/lib" : '');
36 $RLINC = defined $incdir
37 ? "-I$incdir" : (defined $prefix ? "-I$prefix/include" : '');
38 }
39
40 if ($Config{osname} eq 'os2') {
41 # Check ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/
42 $libs = '-lreadline_import';
43 $defs .= ' -DOS2_USEDLL';
44 $lddflags = '';
45 } else {
46 # Search libtermcap, libncurses, or libcurses in this order.
47 # I emulate the behavior of the configure script for bash, and don't
48 # know why AIX prefers curses.
49 # libtermcap.a on HPUX cannot be used for dynamically linked binary.
50 my $PREFER_CURSES = $Config{osname} eq 'aix' || $Config{osname} eq 'hpux';
51 my $TERMCAP_LIB = (! $PREFER_CURSES && &search_lib('-ltermcap'))
52 || &search_lib('-lncurses')
53 || &search_lib('-lcurses');
54 die "Could not find neither libtermcap.a, libncurses.a, or libcurses.\n"
55 unless $TERMCAP_LIB;
56
57 $libs = "-lreadline $TERMCAP_LIB";
58 # Latest Perl in FreeBSD does not need this hack. (Dec.2002)
59 $libs .= ' -lcrypt' if ($Config{osname} =~ /freebsd/i);
60 $lddflags = ($Config{osname} =~ /cygwin/i) ? '-static' : '';
61 }
62
63 # Check version of GNU Readline Library (for version 4.2 and before)
64 {
65 my ($rlmajorver, $rlminorver) =
66 check_readline_version($RLINC, $RLLIB, $defs, $lddflags, $libs);
67
68 if ($rlmajorver < 4 || $rlmajorver == 4 && $rlminorver <= 2) {
69 $defs .= " -DRL_READLINE_VERSION=" .
70 sprintf("0x%02x%02x", $rlmajorver, $rlminorver);
71 $defs .= " -DRL_VERSION_MAJOR=$rlmajorver";
72 $defs .= " -DRL_VERSION_MINOR=$rlminorver";
73 }
74 }
75
76 # generate a Makefile
77 WriteMakefile
78 (
79 NAME => 'Term::ReadLine::Gnu',
80 VERSION_FROM => 'Gnu.pm',
81 LIBS => [ "$RLLIB $libs" ],
82 dynamic_lib => { OTHERLDFLAGS => $lddflags },
83 DEFINE => $defs,
84 ($Config{osname} eq 'os2' ?
85 (
86 IMPORTS => { xfree => 'emxlibcm.401' }, # Yuck!
87 ) : () ),
88 INC => $RLINC,
89 dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' },
90 clean => { FILES => "rlver.c rlver$Config{_exe}" },
91 );
92
93 if ($Config{usesfio} eq 'true') {
94 warn <<'EOM';
95
96 ******************** !!!Warning!!! *********************
97 ** Your Perl is configured as `usesfio' equals true. **
98 ** Term::ReadLine::Gnu may not work with your Perl. **
99 ** If it works, let me know your result of `perl -V'. **
100 ********************************************************
101 EOM
102 }
103
104 exit(0);
105
106 ########################################################################
107 # Search a library '$lib' in $Config{libpth} directories, and return
108 # $lib if exist or undef unless exist.
109
110 # ExtUtils::Liblist::ext() do similar job as this subroutine, but it
111 # warns unnecessary messages.
112 sub search_lib {
113 my ($lib) = @_;
114 unless ($lib =~ /^-l/) {
115 warn "search_lib: illegal arguments, \`$lib\'.\n";
116 return undef;
117 }
118 my $libbase = 'lib' . substr($lib, 2) . $Config{lib_ext};
119 my $libbase_so = 'lib' . substr($lib, 2) . "." . $Config{so};
120 foreach (split(' ', $Config{libpth})) {
121 if (-f $_ . '/' . $libbase) {
122 # print "$_/$libbase\n";
123 print "Found \`$_/$libbase\'.\n";
124 return $lib;
125 } elsif (-f $_ . '/' . $libbase_so) {
126 # print "$_/$libbase_so\n";
127 print "Found \`$_/$libbase_so\'.\n";
128 return $lib;
129 }
130 }
131 return undef;
132 }
133
134 ########################################################################
135 # Check libreadline.a version
136 #
137 # Readline 4.2a introduced the macro
138 # RL_READLINE_VERSION
139 # RL_VERSION_MAJOR
140 # RL_VERSION_MINOR
141 # Someday we don't need this subroutine..
142 sub check_readline_version {
143 my ($RLINC, $RLLIB, $defs, $lddflags, $libs) = @_;
144 my $frlver = 'rlver.c';
145
146 # make temp file
147 open(F, ">$frlver") || die "Cannot open $frlver:$!\n";
148 print F <<'EOF';
149 /* used by Makefile.pl to check the version of the GNU Readline Library */
150 #include <stdio.h>
151 #include <readline/readline.h>
152 main() { puts(rl_library_version); }
153 EOF
154 close(F);
155
156 # compile it
157 my $comp_cmd = "$Config{cc} $RLINC $Config{ccflags} $defs $frlver -o rlver $RLLIB $lddflags $Config{ldflags} $libs";
158 print $comp_cmd, "\n";
159 system($comp_cmd);
160 if ($?) {
161 die <<EOM;
162 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
163 Could not compile $frlver.
164
165 If you have installed the GNU Readline Library (libreadline.{a,so} and
166 readline/readline.h, etc.) on directories for which your perl is not
167 configured to search (refer the value of `ccflags' and `libpath' in
168 the output of `perl -V'), specify the paths as follows;
169
170 perl Makefile.PL --includedir=/yourdir/include --libdir=/yourdir/lib
171 or
172 perl Makefile.PL --prefix=/yourdir
173
174 Note that the GNU Readline Library version 2.0 and earlier causes error
175 here. Update it to version 2.1 and/or later.
176
177 Read INSTALL for more details.
178 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
179 EOM
180 }
181
182 # execute it and get version
183 my $rlver;
184 chomp($rlver = `./rlver`);
185 print "It seems that you have the GNU Readline Library version $rlver.\n";
186 # $rlver may be '8.21-beta3' or '4.2a'
187 return $rlver =~ /(\d+)\.(\d+)/;
188 }
189 # End of Makefile.PL
+424
-0
README less more
0 -*- Indented-text -*-
1 $Id: README,v 1.25 2004-10-17 14:54:11-05 hiroo Exp $
2
3 Term::ReadLine::Gnu --- GNU Readline Library Wrapper Module
4
5 Copyright (c) 2004 Hiroo Hayashi. All rights reserved.
6
7 This program is free software; you can redistribute it and/or
8 modify it under the same terms as Perl itself.
9
10 Description:
11
12 Term::ReadLine::Gnu (TRG) is an implementation of the
13 interface to the GNU Readline Library. This module gives you
14 input line editing facility, input history management
15 facility, word completion facility, etc. It uses the real GNU
16 Readline Library and has the interface with the almost all
17 variables and functions which are documented in the GNU
18 Readline/History Library. So you can program your custom
19 editing function, your custom completion function, and so on
20 with Perl. TRG may be useful for a C programmer to prototype
21 a program which uses the GNU Readline Library.
22
23 TRG is upper compatible with Term::ReadLine included in Perl
24 distribution. Term::ReadLine uses TRG automatically when TRG
25 is available. You can enjoy full line editing feature with
26 Perl debugger which use Term::ReadLine with no patch.
27
28 Ilya Zakharevich distributes his implementation,
29 Term::ReadLine::Perl, which bases on Jeffrey Friedl's
30 readline.pl. His module works very well, and is easy to
31 install because it is written by only Perl. I am trying to
32 make my module compatible with his. He gives useful advises
33 for me. Unfortunately readline.pl simulated old GNU Readline
34 library before TRG was born. For example, it was not 8 bit
35 clean and it warns to the variables in ~/.inputrc which it did
36 not know yet. We Japanese usually use 8 bit characters, so
37 this was bad feature for me. I could make a patch for these
38 problems but I had interest with C interface facility and
39 dynamic loading facility of Perl, so I thought it was a good
40 chance for me to study them. Then I made this module instead
41 of fixing his module.
42
43 Prerequisites:
44 You must have GNU Readline Library Version 2.1 or later. See
45 INSTALL for more detail.
46
47 By a report GNU Readline Library may not work with perl with
48 sfio. Since I do not have sfio library, I am not sure.
49
50 How to build/install:
51 See INSTALL.
52
53 Bugs:
54 There may be many bugs in both programs and documents
55 (especially in English grammar). Comments and bug reports are
56 very welcome.
57
58 Author:
59 Hiroo Hayashi <hiroo.hayashi@computer.org>
60
61
62 Revision History:
63
64 1.15 2004-10-17
65 - readline-5.0 support
66 new function
67 bind_key_if_unbound
68 bind_keyseq
69 bind_keyseq_if_unbound
70 tty_unset_default_bindings
71 add_history_time
72 history_get_time
73 new variable
74 history_write_timestamps
75 completion_quote_character
76 completion_suppress_quote
77 completion_found_quote
78 completion_word_break_hook
79 - double IO stream close bug fix (more use of PerlIO)
80 - warning on 'use Term::ReadLine::Gnu;'.
81
82 1.14 2003-03-16
83 - kludge not to cause segmentation fault on Perl 5.8.0
84 w/PerlIO and FileHandle (ex. CPAN.pm)
85 - clean up Makefile.PL (use strict, fix for HPUX and FreeBSD,
86 fix typo, etc.)
87
88 1.13 2002-07-27
89 - readline-4.2 support
90 new variables
91 rl_completion_suppress_append
92 rl_completion_mark_symlink_dirs
93 new functions
94 rl_replace_line()
95 rl_completion_mode()
96 - tgetstr() calls tput() to apply padding information. No
97 more "$<2>" on prompt.
98 - shadow_redisplay() with ornament works on xterm.
99
100 1.12 2002-03-30
101 - add '-static' flag to 'LDDFLAGS' on Cygwin 1.3.
102 - shadow redisplay does not pester you with warning on a poor
103 terminal, or a terminal with wrong TERM environment variable
104 setting.
105 - update documents
106 - improve coding style of Gnu.xs. (indentation stype, more
107 typemap, etc.)
108
109 1.11 2001-10-27
110 - fix bug of filename-list. Now works with perldb.
111 - by setting rl_line_buffer, proper value are set in rl_end
112 and rl_point.
113 - add history-expand-line command
114 - readline-4.2a support
115 new variable
116 rl_readline_version
117 new function
118 rl_get_termcap
119
120 1.10 2001-04-22
121 - readline-4.2 support
122 new variables
123 rl_attemped_completion_over
124 rl_completion_type
125 rl_deprep_term_function
126 rl_directory_rewrite_hook
127 rl_dispatching
128 rl_editing_mode
129 rl_executing_macro
130 rl_explicit_arg
131 rl_gnu_readline_p
132 rl_num_char_to_read
133 rl_numeric_arg
134 rl_prep_term_function
135 rl_readline_state
136 history_word_delimiters
137 new functions
138 rl_add_funmap_entry
139 rl_alphabetic
140 rl_clear_pending_input
141 rl_crlf
142 rl_deprep_terminal
143 rl_execute_next
144 rl_expand_prompt
145 rl_get_screen_size
146 rl_macro_bind
147 rl_macro_dumper
148 rl_prep_terminal
149 rl_push_macro_input
150 rl_set_keyboard_input_timeout
151 rl_set_paren_blink_timeout(usec)
152 rl_set_prompt
153 rl_set_screen_size
154 rl_setkey
155 rl_show_char
156 rl_tty_set_default_bindings
157 rl_tty_set_default_bindings
158 rl_variable_bind
159 rl_variable_dumper
160 rename functions
161 free_undo_list() -> rl_free_undo_list()
162 ding() -> rl_ding()
163 completion_matches() -> rl_completion_matches()
164 filename_completion_function -> rl_filename_completion_function()
165 username_completion_function -> rl_username_completion_function()
166 max_input_history -> history_max_entries
167
168 - fix bug when ornament string does not use any control characters.
169 - add Gnu/euc_jp.pm which is still experimental.
170 - typemap: redefine FILE * to support perl 5.7.
171
172 1.09 2000-04-04
173 - Perl-5.6 now does not warn without `POLLUTE=1' during `perl
174 Makefile.PL'. (Thanks to PPPort.)
175 - change the default terminal escape sequence to stop
176 underline.
177 - support rl_already_prompted and rl_on_new_line_with_prompt()
178 which are introduced by readline-4.1-beta.
179 - support rl_funmap_names() and rl_last_func.
180 - update documentation.
181
182 1.08 1999-12-30
183 - fix Makefile.PL to search libreadline.* correctly even if it
184 is not included in the paths specified with the configuration
185 variable `libpth'.
186 - add dummy assignment to %ENV before $self->initialize()
187
188 1.07 1999-07-19
189 - search path for the GNU Readline Library is specified by
190 command line argument instead of editing Makefile.PL.
191 - fix bug of t/readline.t which warns for the GNU Readline
192 version 2.1.
193 - Makefile.PL now looks for shared libraries not only for
194 static ones
195 - add support for Cygwin b20.1 and HPUX (HPUX support may be
196 incomplete.)
197 - no change on Gnu.pm and Gnu.xs
198
199 1.06 1999-05-05
200 - fix a bug which causes segmentation fault when
201 completion_matches() returns long list.
202 - fix a bug which causes segmentation fault when
203 perl subroutine returns a list of undef in
204 attempted_completion_function_wrapper().
205 - disable Autosplit for AutoLoad.pm bug distributed with Perl
206 5.004 or earlier.
207 - add check if perl is configured with sfio to Makefile.PL.
208
209 1.05 1999-04-04
210 - bug fix
211 Term::ReadLine::Perl compatibility variable
212 `completion_function' and function `rl_filename_list' are
213 now compatible with Term::ReadLine::Perl. Completion code
214 written for Term::ReadLine::Perl, e.g. perl5db.pl, works
215 with this module.
216
217 search text of list_completion is quoted
218
219 - add support of new variables and functions introduced by GNU
220 Readline Library Version 4.0
221 new variable
222 rl_erase_empty_line
223 rl_catch_signals
224 rl_catch_sigwinch
225 rl_pre_input_hook
226 completion_display_matches_hook
227 history_inhibit_expansion_function
228 new function
229 rl_display_match_list()
230 rl_cleanup_after_signal()
231 rl_free_line_state()
232 rl_reset_after_signal()
233 rl_resize_terminal()
234 rl_set_signals()
235 rl_clear_signals()
236
237 - add support of variables and function which were not supported
238 yet
239 filename_quoting_function
240 filename_dequoting_function
241 char_is_quoted_p
242 ignore_some_completions_function
243 directory_completion_hook
244
245 rl_get_all_function_names()
246
247 - add support of functions which are specific to Term::ReadLine::Gnu
248 display_readline_version()
249 change_ornaments()
250 shadow_redisplay()
251
252 - rename some functions for the orthogonality
253 rl_unbind_function_in_map to rl_unbind_function
254 rl_unbind_command_in_map to rl_unbind_command
255
256 - `make test' is executed non-interactively and comprehensively
257
258 - sample code improvement
259 eg/perlsh
260 Perl symbol completion was rewritten and much more
261 improved.
262 SIGINT clears the current line
263 add support \w (current working package) in the prompt
264 string
265 add support `afterinit' hook as Perl debugger.
266
267 eg/pftp
268 password input is now invisible.
269 displaying of completion candidates are improved by using
270 completion_display_matches_hook.
271
272 - internal changes
273 Perl code for Term::ReadLine::Gnu::XS package are moved
274 into separate file Gnu/XS.pm and `AutoSplit'ed.
275
276 replace operate_and_get_next() to one borrowed from bash.
277
278 1.04 1999-02-23
279 - fix a bug by which $if-$endif feature in ~/.inputrc was
280 disabled.
281 - works with GNU Readline Library version 4.0 in which some
282 function names were changed. New functions, that are
283 introduced in the new library, were not supported in this
284 release.
285
286 1.03 1998-09-27
287 - fix a bug when prompt string includes non-printing
288 characters and an input line is longer than terminal width.
289 Constants, RL_PROMPT_START_IGNORE and RL_PROMPT_END_IGNORE,
290 are incorporated from the GNU Readline Library to support
291 this feature.
292 - now works on a system which does not have /etc/termcap and
293 has termcap compatible library, libncurses or libcurses.
294
295 1.02 1998-08-14
296 - fix a bug in Makefile.PL, which quoted a variable, $increadlinedir,
297 with a pair of single quotes
298 - this is an internal revision
299
300 1.01 1998-05-13
301 - support readline-2.2
302 add rl_unbind_function_in_map() and rl_unbind_command_in_map()
303 Makefile.PL checks the version of the GNU Readline Library
304
305 - define rl_save_prompt() and rl_restore_prompt()
306
307 - document fix
308 'Changes' file is removed. It is merged into README file.
309 fix a bug in a sample program of rl_completion_entry_function
310
311 1.00 1998-04-15
312 - the 1st major release
313
314 - ornaments feature is now on by default as recent
315 Term::ReadLine and Term::ReadLine::Perl
316
317 - document fix
318 remove description related to mymalloc
319
320 - add ornaments-change function to t/readline.t which
321 demonstrates rl_message().
322
323 0.10 1998-03-31
324 - new functions/variables
325 ornaments support
326 newTTY() (not tested)
327 max_input_history
328 read_history() (an aliase of read_history_range())
329 unstifle_history()
330 history_search_pos()
331 history_list()
332 history_tokenize() (Thank you, Tim Thomas)
333 history_arg_extract()
334 get_history_event()
335 - new sample/test programs
336 eg/fileman
337 t/history.t
338 - bug fix
339 dynamic loading works on Solaris2.x (define xfree() locally)
340 readline() calls add_history() only when MinLength > 0
341 Feature `addhistory' is renamed to `addHistory' since
342 Term/ReadLine.pm is fixed.
343 add NULL check for all sv_setpv()
344 remove arguments 'pos' from history_search()
345 - misc
346 change my E-mail address
347
348 0.09 Mon Aug 25 00:33:29 1997
349 - add documentation about readline-2.1.tar.gz
350 - add documentation about Solaris 2.5 with dynamic loading
351 - bug fix
352 fix for Digital Unix C compiler
353 - add two sample programs
354 eg/pftp An ftp client with the GNU Readline support
355 eg/ptksh+ Simple perl/Tk shell which demonstrates
356 the callback functions
357
358 0.08 Sun Apr 13 23:24:52 1997
359
360 - bug fix: AddHistory() accepts list again.
361 - move perlsh into eg/.
362 - add eg/ptksh+ which demonstrates the callback functions.
363 Thank you Achim.
364 - add eg/pftp: an ftp client which has much the GNU Readline support.
365 - Author's Email address is changed.
366 - internal functions, fetch_var() and store_var(), are removed.
367
368 0.07 Wed Mar 19 02:26:06 1997
369
370 - interface to internal function and variables are changed.
371 New interface is compatible with new Term::ReadLine.pm which
372 is distributed with Perl 5.003_92 and later. But it is not
373 compatible with previous release.
374
375 - add method interface to all internal function
376 - add Attribs method to access internal variables
377 - EXPORT_OK contains only some constant definitions
378
379 - tkRunning support (new ReadLine.pm is required)
380 - add document
381 - bug fixes
382 - XS bugs correspond to callback interface
383 - fix _rl_store_function() and _rl_fetch_function()
384 - fix prototype of append_history
385 - use new _rl_store_rl_line_buffer() instead of
386 reallocate rl_line_buffer.
387 - etc.
388
389 0.06 Wed Feb 5 01:26:27 1997
390 - the first revision on CPAN
391 - support for non ANSI C compiler
392 - rename addhistory to AddHistory
393 - checked by gcc -Wall
394 - fix void_arg_func_wrapper()
395 - add hook for rl_startup_hook in readline()
396 - update documents
397
398 0.05 Sat Jan 25 00:06:56 1997
399 - Fix for Perl 5.002 and 5.003
400 escape from an strange Exporter's behavior
401 remove white spaces in prototype
402 add argument explicitly
403
404 0.04 Thu Jan 23 00:25:45 1997
405 - This revision supports readline-2.1 or later. readline-2.0
406 is not supported.
407 - implement almost all GNU Readline/History Library variables
408 and functions
409 - use filehandle directly to access rl_instream and rl_outstream
410 - define operate_and_get_next and bind to "\C-o" by default
411
412 0.03 Sun Nov 24 23:34:27 1996
413 - OS/2 support by Ilya Zakharevich <ilya@math.ohio-state.edu>
414 - implement $rl_completer_word_break_characters
415 - define HAVE_STRING_H by checking $Config{strings}
416 - remove verbose prototypes on methods
417
418 0.02 Thu Nov 21 00:22:11 1996
419 - fix to install on
420 SunOS 4.1.3, Solaris 2.3, AIX 4.1.3
421
422 0.01 Wed Nov 20 01:14:09 1996
423 - The 1st alpha release revision (tested on Linux 1.2.13)
+174
-0
debian/changelog less more
0 libterm-readline-gnu-perl (1.15-2) unstable; urgency=low
1
2 * Moved to libreadline5-dev, fixing double-free/corruption (Closes:
3 #304604, #322746, #323849)
4
5 -- Gunnar Wolf <gwolf@debian.org> Tue, 30 Aug 2005 12:23:11 -0500
6
7 libterm-readline-gnu-perl (1.15-1) unstable; urgency=low
8
9 * New upstream release
10 * New maintainer: Debian Perl group
11 * Bumped up standards-version to 3.6.2
12
13 -- Gunnar Wolf <gwolf@debian.org> Fri, 15 Jul 2005 14:35:39 +0300
14
15 libterm-readline-gnu-perl (1.14-2) unstable; urgency=low
16
17 * Bug fix: "libterm-readline-gnu-perl: package description syntax",
18 thanks to Nicolas Bertolissio (Closes: #207230).
19 * Deleted watch file.
20
21 -- Joerg Jaspert <joerg@debian.org> Sat, 15 Nov 2003 22:47:38 +0100
22
23 libterm-readline-gnu-perl (1.14-1) unstable; urgency=low
24
25 * New Upstream Version (closes: #187448)
26 - kludge not to cause segmentation fault on Perl 5.8.0
27 w/PerlIO and FileHandle (ex. CPAN.pm)
28 - clean up Makefile.PL (use strict, fix for HPUX and FreeBSD,
29 fix typo, etc.)
30 * Use patch from Nicolas Bertolissio to fix the
31 "unintialized value message" (closes: #99843)
32 * Update Section to perl.
33 * Use patch from Nicolas Bertolissio to fix the "new" method which
34 (closes: #204362)
35
36 -- Joerg Jaspert <joerg@debian.org> Fri, 22 Aug 2003 18:38:29 +0200
37
38 libterm-readline-gnu-perl (1.13-1.1) unstable; urgency=low
39
40 * NMU for perl 5.8. No changes except a build-dep on perl >= 5.8
41
42 -- Joey Hess <joeyh@debian.org> Wed, 31 Jul 2002 05:19:05 +0000
43
44 libterm-readline-gnu-perl (1.13-1) unstable; urgency=low
45
46 * New Upstream Version
47 - readline-4.2 support
48 - new variables
49 rl_completion_suppress_append
50 rl_completion_mark_symlink_dirs
51 - new functions
52 rl_replace_line()
53 rl_completion_mode()
54 - tgetstr() calls tput() to apply padding information. No
55 more "$<2>" on prompt.
56 - shadow_redisplay() with ornament works on xterm.
57
58 -- Joerg Jaspert <joerg@debian.org> Sun, 28 Jul 2002 18:25:29 +0200
59
60 libterm-readline-gnu-perl (1.12-5) unstable; urgency=low
61
62 * Applied Patch from Upstream which closes the bug for
63 "Ornaments and shadow_redisplay don't mix" (closes: #45949)
64
65 -- Joerg Jaspert <joerg@debian.org> Sun, 28 Jul 2002 02:21:38 +0200
66
67 libterm-readline-gnu-perl (1.12-4) unstable; urgency=low
68
69 * Rebuild with newest libreadline.
70 * Updated Standards-version in debian/control.
71 * Build-Depends for debhelper now for Version > 4.x and DH_COMPAT in
72 debian/rules is 4 now.
73 * Cleaned debian/rules a bit.
74 * Remove empty /usr/share/perl5 from .deb
75
76 -- Joerg Jaspert <joerg@debian.org> Sun, 21 Jul 2002 23:53:49 +0200
77
78 libterm-readline-gnu-perl (1.12-3) unstable; urgency=low
79
80 * Changed my Email to the @debian.org
81 * Added debian/watch file for uscan.
82
83 -- Joerg Jaspert <joerg@debian.org> Thu, 18 Apr 2002 21:20:49 +0200
84
85 libterm-readline-gnu-perl (1.12-2) unstable; urgency=low
86
87 * Updated debian/copyright
88 * This Bug is closed since 1.10 so close it now. (closes: #69816)
89
90 -- Joerg Jaspert (JJ) <joerg@goliathbbs.dnsalias.net> Fri, 5 Apr 2002 18:22:50 +0200
91
92 libterm-readline-gnu-perl (1.12-1) unstable; urgency=low
93
94 * New Maintainer (closes: #141230)
95 * Acknowledge the NMU Bugfixes.
96 (closes: #67054, #67804, #60845, #87030, #65374, #80688, #84505, #78657, #67745, #87405)
97 * New Upstream Version.
98 * Removed postinst and prerm. debhelper creates the same one, we dont need special things in
99 here.
100 * Reworked debian/rules to use more of debhelper and be a little bit easier to read.
101 Hope i dont break anything with it.
102
103 -- Joerg Jaspert (JJ) <joerg@goliathbbs.dnsalias.net> Fri, 5 Apr 2002 15:56:11 +0200
104
105 libterm-readline-gnu-perl (1.10-1) unstable; urgency=low
106
107 * New upstream version
108 * Made minor modifications to debian/*. Package continues to be lintian
109 clean primarily due to Matthias's and Raphael's work.
110 * It looks like bug #69816 is fixed, I've asked the submitter if they
111 can duplicate it with this new package.
112 * I can still repro bug #45949 and I'll check into it.
113
114 -- Darren Stalder <torin@daft.com> Thu, 10 May 2001 23:35:04 -0700
115
116 libterm-readline-gnu-perl (1.09-0.1) unstable; urgency=low
117
118 * Non Maintainer Upload.
119 * New upstream version. Closes: #78657, #84505
120 * Correct permissions on postinst/prerm. Closes: #67804
121 * Built against latest libraries. Closes: #65374
122 * Updated to latest perl policy. Closes: #80668
123 * This new upstream version does build with the
124 latest libraries. Closes: #87030
125 * Commented out the make test. On the command line it does work ok
126 but it waits indefinitely when runned from debian/rules with debuild.
127 * Updated to latest policy. Lintian clean again.
128
129 -- Raphael Hertzog <hertzog@debian.org> Sat, 24 Feb 2001 14:17:53 +0100
130
131 libterm-readline-gnu-perl (1.07-2.1) unstable; urgency=low
132
133 * NMU, recompiled for libreadline4 (closes grave #60845, #67054).
134 * debian/control: Added Build-Depends.
135 * Made lintian clean.
136
137 -- Matthias Klose <doko@cs.tu-berlin.de> Tue, 25 Jul 2000 06:11:57 +0200
138
139 libterm-readline-gnu-perl (1.07-2) unstable; urgency=low
140
141 * make test opens /dev/tty. The autobuilders run from cron and
142 therefore don't have a /dev/tty. Therefore the package fails to build
143 under the autobuilders.
144 Using the idea from Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>,
145 make test only runs if /dev/tty is available. Closes Bug#42882.
146
147 -- Darren Stalder <torin@daft.com> Fri, 13 Aug 1999 00:59:45 -0700
148
149 libterm-readline-gnu-perl (1.07-1) unstable; urgency=low
150
151 * New upstream version.
152 * Use correct LDLOADLIBS line. Thanks to Manish Singh <yosh@gimp.org>
153 for this. Fixes Bug#41868,#41677,#42018.
154
155 -- Darren Stalder <torin@daft.com> Tue, 10 Aug 1999 04:07:20 -0700
156
157 libterm-readline-gnu-perl (1.06-1) unstable; urgency=low
158
159 * New Maintainer.
160 * New upstream version.
161 * Complies with Perl packaging standard 1.0.
162 * Completely rewrote debian/rules to my standards.
163 * Rewrote control description section.
164 * Changed source package name to be the same as the (one) binary package.
165 * Changed priority to optional.
166
167 -- Darren Stalder <torin@daft.com> Tue, 13 Jul 1999 01:24:06 -0700
168
169 libterm-readline-gnu-perl (1.03-1) unstable; urgency=low
170
171 * Initial release.
172
173 -- Ben Gertzfield <che@debian.org> Tue, 13 Oct 1998 17:44:34 -0700
+19
-0
debian/control less more
0 Source: libterm-readline-gnu-perl
1 Section: perl
2 Priority: optional
3 Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.debian.org>
4 Uploaders: Gunnar Wolf <gwolf@debian.org>
5 Standards-Version: 3.6.2
6 Build-Depends: debhelper (>= 4.0.19), perl (>= 5.8), libreadline5-dev
7
8 Package: libterm-readline-gnu-perl
9 Architecture: any
10 Depends: ${perl:Depends}, ${shlibs:Depends}
11 Description: Perl extension for the GNU Readline/History Library
12 This is an implementation of a Perl interface to the GNU Readline
13 Library. This module gives you input line editing, input history
14 management, word completion, and other similar facilities. This module
15 gives you access to almost all variables and functions documented in
16 the GNU ReadLine/History Library. This means you can write your custom
17 editing function, your custom completion function, and so on with Perl.
18 You may find it useful for prototyping before programming with C.
+21
-0
debian/copyright less more
0 This package was debianized by Joerg Jaspert <joerg@debian.org> on
1 Fri, 05 Apr 2002 16:00:00 +0200.
2
3 The previous maintainers for this Package are:
4 Darren Stalder <torin@daft.com>
5 Ben Gertzfield <che@debian.org>.
6
7 It was downloaded from http://www.perl.org/CPAN/authors/Hiroo_HAYASHI/
8
9 Upstream Author: Hiroo Hayashi <hiroo.hayashi@computer.org>
10
11 Copyright (c) 2002 Hiroo Hayashi. All rights reserved.
12 This program is free software; you can redistribute it and/or
13 modify it under the same terms as Perl itself.
14
15 Perl is distributed under either the terms of the Artistic License
16 or the GPL, your choice.
17
18 On Debian systems, the Artistic License is available in
19 the file /usr/share/common-licenses/Artistic. The GNU General Public
20 License is available in the file /usr/share/common-licenses/GPL.
+84
-0
debian/rules less more
0 #!/usr/bin/make -f
1 #-*- makefile -*-
2
3 #export DH_VERBOSE=1
4 export DH_COMPAT=4
5
6 PACKAGE=$(shell dh_listpackages)
7
8 ifndef PERL
9 PERL = /usr/bin/perl
10 endif
11
12 ifndef DESTDIR
13 DESTDIR=..
14 endif
15
16 TMP =`pwd`/debian/$(PACKAGE)
17 DOCDIR = $(TMP)/usr/share/doc/libterm-readline-gnu-perl
18
19 OPTIMIZE = -O2 -Wall
20 ifneq (,$(findstring debug,$(DEB_BUILD_OPTIONS)))
21 OPTIMIZE += -g
22 endif
23
24 clean:
25 dh_testdir
26 dh_testroot
27 rm -f build-stamp
28 [ ! -f Makefile ] || $(MAKE) realclean
29 dh_clean
30
31 build: build-stamp
32 build-stamp:
33 dh_testdir
34
35 $(PERL) Makefile.PL INSTALLDIRS=vendor
36 $(MAKE) all LDLOADLIBS="-lreadline -lncurses -lc" LD_RUN_PATH="" OPTIMIZE="$(OPTIMIZE)"
37 touch build-stamp
38
39
40 install:
41 dh_testdir
42 dh_testroot
43 dh_clean -k
44 dh_installdirs
45
46 $(MAKE) install PREFIX=$(TMP)/usr
47
48 find $(TMP) \( -name '*.pm' -o -name '*.pl' \) -print0 | xargs --null --no-run-if-empty \
49 $(PERL) -i -pe '$$_ = "#!/usr/bin/perl$$1\n" if m|^#!.*/perl(.*)$$|;'
50
51 install -d $(DOCDIR)/examples
52 cp -ra eg/* $(DOCDIR)/examples
53 chmod a-x $(DOCDIR)/examples/*
54 find $(DOCDIR)/examples -type f -print0 | xargs --null --no-run-if-empty \
55 $(PERL) -i -pe '$$_ = "#!/usr/bin/perl$$1\n" if m|^#!.*/perl(.*)$$|;'
56 -gzip -9rf $(DOCDIR)/examples
57 -cd debian; find -type d -empty -exec rmdir \{} \;
58
59
60 # Build architecture-independent files here.
61 binary-indep: build install
62 # We have nothing to do by default.
63
64 # Build architecture-dependent files here.
65 binary-arch: build install
66 dh_testdir
67 dh_testroot
68 dh_installdocs README
69 dh_installman
70 dh_installchangelogs
71 dh_link
72 dh_strip
73 dh_compress
74 dh_fixperms
75 dh_installdeb
76 dh_perl
77 dh_shlibdeps
78 dh_gencontrol
79 dh_md5sums
80 dh_builddeb --destdir=$(DESTDIR)
81
82 binary: binary-indep binary-arch
83 .PHONY: build clean binary-indep binary-arch binary
+309
-0
eg/fileman less more
0 #!/usr/local/bin/perl
1 #
2 # $Id: fileman,v 1.1 1998-02-28 19:01:24+09 hayashi Exp $
3 #
4 # This is a sample program of Term::ReadLine::Gnu perl module. The
5 # origin is a C program in the GNU Readline Libarary manual Edition
6 # 2.1, "2.5.4 A Short Completion Example". This program is under GPL.
7 #
8 # Copyright (C) 1989, 1991 Free Software Foundation, Inc.
9 # Original C version
10 # Copyright (C) 1998 Hiroo Hayashi
11 # Perl version
12
13 # fileman.c -- A tiny application which demonstrates how to use the
14 # GNU Readline library. This application interactively allows users
15 # to manipulate files and their modes.
16
17 use strict;
18 use Term::ReadLine;
19
20 # A structure which contains information on the commands this program
21 # can understand.
22
23 my %commands =
24 ('cd' => { func => \&com_cd, doc => "Change to directory DIR" },
25 'delete' => { func => \&com_delete, doc => "Delete FILE" },
26 'help' => { func => \&com_help, doc => "Display this text" },
27 '?' => { func => \&com_help, doc => "Synonym for `help'" },
28 'list' => { func => \&com_list, doc => "List files in DIR" },
29 'ls' => { func => \&com_list, doc => "Synonym for `list'" },
30 'pwd' => { func => \&com_pwd,
31 doc => "Print the current working directory" },
32 'quit' => { func => \&com_quit, doc => "Quit using Fileman" },
33 'rename' => { func => \&com_rename, doc => "Rename FILE to NEWNAME" },
34 'stat' => { func => \&com_stat, doc => "Print out statistics on FILE" },
35 'view' => { func => \&com_view, doc => "View the contents of FILE" },
36 );
37
38 # The name of this program, as taken from argv[0].
39 my $progname = $0;
40
41 # When non-zero, this global means the user is done using this program.
42 my $done = 0;
43
44 my $term = initialize_readline(); # Bind our completer.
45 $term->MinLine(0); ## disable implict call of add_history()
46
47 # Loop reading and executing lines until the user quits.
48 while ($done == 0) {
49 my $line = $term->readline ("FileMan: ");
50
51 last unless defined $line;
52
53 # Remove leading and trailing whitespace from the line. Then, if
54 # there is anything left, add it to the history list and execute
55 # it.
56 my $s = stripwhite($line);
57
58 if ($s) {
59 $term->AddHistory($s); ## normally this is done implictly
60 execute_line($s);
61 }
62 }
63
64 exit 0;
65
66 # Execute a command line.
67 sub execute_line {
68 my $line = shift;
69
70 my ($word, $arg) = split(' ', $line);
71
72 my $command = find_command ($word);
73
74 unless ($command) {
75 printf STDERR "$word: No such command for FileMan.\n";
76 return (-1);
77 }
78
79 # Call the function.
80 return (&{$command->{func}}($arg));
81 }
82
83 # Look up NAME as the name of a command, and return a pointer to that
84 # command. Return a NULL pointer if NAME isn't a command name.
85 sub find_command {
86 my $name = shift;
87
88 return $commands{$name};
89 }
90
91 # Strip whitespace from the start and end of STRING. Return a pointer
92 # into STRING.
93 sub stripwhite {
94 my $string = shift;
95 $string =~ s/^\s*//;
96 $string =~ s/\s*$//;
97 return $string;
98 }
99
100 #/* **************************************************************** */
101 #/* */
102 #/* Interface to Readline Completion */
103 #/* */
104 #/* **************************************************************** */
105
106 # Tell the GNU Readline library how to complete. We want to try to
107 # complete on command names if this is the first word in the line, or
108 # on filenames if not.
109 sub initialize_readline
110 {
111 # Allow conditional parsing of the ~/.inputrc file.
112 my $term = new Term::ReadLine 'FileMan';
113
114 # Tell the completer that we want a crack first.
115 $term->Attribs->{attempted_completion_function} = \&fileman_completion;
116
117 return $term;
118 }
119
120 # Attempt to complete on the contents of TEXT. START and END bound
121 # the region of rl_line_buffer that contains the word to complete.
122 # TEXT is the word to complete. We can use the entire contents of
123 # rl_line_buffer in case we want to do some simple parsing. Return
124 # the array of matches, or NULL if there aren't any.
125 sub fileman_completion {
126 my ($text, $line, $start, $end) = @_;
127
128 my @matches = ();
129
130 # If this word is at the start of the line, then it is a command
131 # to complete. Otherwise it is the name of a file in the current
132 # directory.
133 @matches = $term->completion_matches ($text, \&command_generator)
134 if ($start == 0);
135
136 return @matches;
137 }
138
139 # Generator function for command completion. STATE lets us know
140 # whether to start from scratch; without any state (i.e. STATE == 0),
141 # then we start at the top of the list.
142
143 ## Term::ReadLine::Gnu has list_completion_function similar with this
144 ## function. I defined new one to be compared with original C version.
145 {
146 my $list_index;
147 my @name;
148
149 sub command_generator {
150 my ($text, $state) = @_;
151
152 # If this is a new word to complete, initialize now. This
153 # includes saving the length of TEXT for efficiency, and
154 # initializing the index variable to 0.
155 unless ($state) {
156 $list_index = 0;
157 @name = keys(%commands);
158 }
159
160 # Return the next name which partially matches from the
161 # command list.
162 while ($list_index <= $#name) {
163 $list_index++;
164 return $name[$list_index - 1]
165 if ($name[$list_index - 1] =~ /^$text/);
166 }
167 # If no names matched, then return NULL.
168 return undef;
169 }
170 }
171
172 #/* **************************************************************** */
173 #/* */
174 #/* FileMan Commands */
175 #/* */
176 #/* **************************************************************** */
177
178
179 # List the file(s) named in arg.
180 sub com_list {
181 my $arg = shift;
182
183 return (system ("ls -FClg $arg"));
184 }
185
186 sub com_view {
187 my $arg = shift;
188 return 1 unless (valid_argument ("view", $arg));
189
190 return (system "more $arg");
191 }
192
193 sub com_rename {
194 too_dangerous ("rename");
195 return (1);
196 }
197
198 sub com_stat {
199 my $arg = shift;
200
201 return (1) unless valid_argument ("stat", $arg);
202
203 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
204 $atime,$mtime,$ctime,$blksize,$blocks);
205
206 unless (($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
207 $atime,$mtime,$ctime,$blksize,$blocks) = stat($arg)) {
208 print STDERR "$arg: $!\n";
209 return (1);
210 }
211
212 printf("Statistics for \`$arg\':\n");
213
214 printf("%s has %d link%s, and is %d byte%s in length.\n", $arg,
215 $nlink, ($nlink == 1) ? "" : "s",
216 $size, ($size == 1) ? "" : "s");
217 printf("Inode Last Change at: %s\n", scalar localtime ($ctime));
218 printf(" Last access at: %s\n", scalar localtime ($atime));
219 printf(" Last modified at: %s\n", scalar localtime ($mtime));
220 return (0);
221 }
222
223 sub com_delete {
224 too_dangerous("delete");
225 return (1);
226 }
227
228 # Print out help for ARG, or for all of the commands if ARG is not
229 # present.
230 sub com_help {
231 my $arg = shift;
232 my $printed = 0;
233
234 if ($commands{$arg}) {
235 printf ("%s\t\t%s.\n", $arg, $commands{$arg}->{doc});
236 $printed++;
237 }
238
239 unless ($printed) {
240 print "No commands match \`$arg\'. Possibilties are:\n";
241
242 foreach (sort keys(%commands)) {
243 # Print in six columns.
244 if ($printed == 6) {
245 $printed = 0;
246 print "\n";
247 }
248
249 print "$_\t";
250 $printed++;
251 }
252
253 print "\n" if ($printed);
254
255 }
256 return (0);
257 }
258
259 # Change to the directory ARG.
260 sub com_cd {
261 my $arg = shift;
262 unless (chdir ($arg)) {
263 print STDERR "$arg: $!\n";
264 return 1;
265 }
266
267 com_pwd();
268 return (0);
269 }
270
271 # Print out the current working directory.
272 sub com_pwd {
273 my $dir = $ENV{PWD} || `pwd`;
274
275 unless ($dir) {
276 print ("Error getting pwd: $dir\n");
277 return 1;
278 }
279
280 print ("Current directory is $dir\n");
281 return 0;
282 }
283
284 # The user wishes to quit using this program. Just set DONE non-zero.
285 sub com_quit {
286 $done = 1;
287 0;
288 }
289
290 # Function which tells you that you can't do this.
291 sub too_dangerous {
292 my $caller = shift;
293 printf STDERR
294 ("%s: Too dangerous for me to distribute. Write it yourself.\n",
295 $caller);
296 }
297
298 # Return non-zero if ARG is a valid argument for CALLER, else print an
299 # error message and return zero.
300 sub valid_argument {
301 my ($caller, $arg) = @_;
302 if (! $arg) {
303 printf STDERR ("%s: Argument required.\n", $caller);
304 return (0);
305 }
306
307 return (1);
308 }
+472
-0
eg/perlsh less more
0 #! /usr/local/bin/perl
1 #
2 # $Id: perlsh,v 1.24 2001-10-27 22:59:15-05 hayashi Exp $
3 #
4 # Copyright (c) 2000 Hiroo Hayashi. All Rights Reserved.
5 #
6 # This program is free software; you can redistribute it and/or
7 # modify it under the same terms as Perl itself.
8
9 =head1 NAME
10
11 perlsh - one-line perl evaluator with line editing function and
12 variable name completion function
13
14 =head1 SYNOPSIS
15
16 perlsh
17
18 =head1 DESCRIPTION
19
20 This program reads input a line, and evaluates it by perl interpreter,
21 and prints the result. If the result is a list value then each value
22 of the list is printed line by line. This program can be used as a
23 very strong calculator which has whole perl functions.
24
25 This is a sample program Term::ReadLine::Gnu module. When you input a
26 line, the line editing function of GNU Readline Library is available.
27 Perl symbol name completion function is also available.
28
29 =cut
30
31 package PerlSh;
32
33 use strict;
34 use Term::ReadLine;
35
36 use vars qw($PS1 $PS2 $HISTFILE $HISTSIZE $INPUTRC $STRICT
37 $HOSTNAME $LOGNAME $CWP);
38
39 #$PS1 = '$ ';
40 $PS1='\w[\!]$ ';
41 $PS2 = '> ';
42 $HISTFILE = ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlsh_history";
43 $HISTSIZE = 256;
44 $INPUTRC = ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlshrc";
45 $STRICT = 0;
46
47 $HOSTNAME = $ENV{HOSTNAME};
48 $LOGNAME = $ENV{LOGNAME};
49 $CWP = 'main'; # current working package
50
51 package main;
52 if (-f $PerlSh::INPUTRC) {
53 do $PerlSh::INPUTRC;
54 }
55
56 package PerlSh;
57
58 use vars qw($term $attribs); # to access as `$PerlSh::term' from prompt
59 $term = new Term::ReadLine 'PerlSh';
60 $attribs = $term->Attribs;
61
62 $term->bind_key(ord "^", 'history-expand-line', 'emacs-meta');
63 $term->bind_key(ord "\cv", 'display-readline-version', 'emacs-ctlx');
64 $term->bind_key(ord "\cc", 'abort'); # not works yet FIXME!!!
65
66 if (defined &main::afterinit) {
67 package main;
68 &afterinit;
69 package PerlSh;
70 }
71
72 &toplevel; # never returns
73
74 ########################################################################
75 sub toplevel {
76 # disable implicit add_history() call
77 $term->MinLine(undef);
78
79 $term->stifle_history($HISTSIZE);
80 if (-f $HISTFILE) {
81 $term->ReadHistory($HISTFILE)
82 or warn "perlsh: cannot read history file: $!\n";
83 }
84 $attribs->{attempted_completion_function} = \&attempt_perl_completion;
85 $attribs->{special_prefixes} = '$@%&';
86 $attribs->{completion_display_matches_hook}
87 = \&perl_symbol_display_match_list;
88
89 $SIG{INT} = sub {
90 $term->modifying;
91 $term->delete_text;
92 $attribs->{point} = $attribs->{end} = 0;
93 $term->redisplay;
94 };
95
96 my ($strict, $command, @result);
97 $strict = $STRICT ? '' : 'no strict;';
98 while (defined($command = &reader)) {
99 @result = eval ("$strict package $CWP; $command");
100 use strict;
101 if ($@) { print "Error: $@\n"; next; }
102 printer (@result);
103 $CWP = $1 if ($command =~ /^\s*package\s+([\w:]+)/);
104 }
105 &quit;
106 }
107
108 sub quit {
109 $term->WriteHistory($HISTFILE)
110 or warn "perlsh: cannot write history file: $!\n";
111 exit (0);
112 }
113
114 sub reader {
115 my ($line, $command);
116 $command = '';
117 while (1) {
118 $line = $term->readline($command ? $PS2 : prompt($PS1));
119 return undef unless (defined $line);
120
121 if ($line =~ /\\$/) {
122 chop $line;
123 $command = $command ? $command . " $line" : $line;
124 } else {
125 $command = $command ? $command . " $line" : $line;
126 $term->addhistory($command) if (length($command) > 0);
127 return $command;
128 }
129 }
130 }
131
132 sub printer {
133 my (@res) = @_;
134 my ($i);
135 foreach $i (@res) { print "$i\n"; }
136 }
137
138 sub prompt {
139 local($_) = @_;
140 # if reference to a subroutine return the return value of it
141 return &$_ if (ref($_) eq 'CODE');
142
143 # \h: hostname, \u: username, \w: package name, \!: history number
144 s/\\h/$HOSTNAME/g;
145 s/\\u/$LOGNAME/g;
146 s/\\w/$CWP/g;
147 s/\\!/$attribs->{history_base} + $attribs->{history_length}/eg;
148 $_;
149 }
150
151 #
152 # custom completion for Perl
153 #
154
155 sub perl_symbol_display_match_list ($$$) {
156 my($matches, $num_matches, $max_length) = @_;
157 map { $_ =~ s/^((\$#|[\@\$%&])?).*::(.+)/$3/; }(@{$matches});
158 $term->display_match_list($matches);
159 $term->forced_update_display;
160 }
161
162 sub attempt_perl_completion ($$$$) {
163 my ($text, $line, $start, $end) = @_;
164
165 no strict qw(refs);
166 if (substr($line, 0, $start) =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/) {
167 # $foo{key, $foo->{key
168 $attribs->{completion_append_character} = '}';
169 return $term->completion_matches($text,
170 \&perl_hash_key_completion_function);
171 } elsif (substr($line, 0, $start) =~ m/\$([\w:]+)\s*->\s*['"]?$/) {
172 # $foo->method
173 $attribs->{completion_append_character} = ' ';
174 return $term->completion_matches($text,
175 \&perl_method_completion_function);
176 } else { # Perl symbol completion
177 $attribs->{completion_append_character} = '';
178 return $term->completion_matches($text,
179 \&perl_symbol_completion_function);
180 }
181 }
182
183 # static global variables for completion functions
184 use vars qw($i @matches);
185
186 sub perl_hash_key_completion_function ($$) {
187 my($text, $state) = @_;
188
189 if ($state) {
190 $i++;
191 } else {
192 # the first call
193 $i = 0; # clear index
194 my ($var,$arrow) = (substr($attribs->{line_buffer},
195 0, $attribs->{point} - length($text))
196 =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/); # });
197 no strict qw(refs);
198 $var = "${CWP}::$var" unless ($var =~ m/::/);
199 if ($arrow) {
200 my $hashref = eval "\$$var";
201 @matches = keys %$hashref;
202 } else {
203 @matches = keys %$var;
204 }
205
206 }
207 for (; $i <= $#matches; $i++) {
208 return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
209 }
210 return undef;
211 }
212
213 sub _search_ISA ($) {
214 my ($mypkg) = @_;
215 no strict 'refs';
216 my $isa = "${mypkg}::ISA";
217 return $mypkg, map _search_ISA($_), @$isa;
218 }
219
220 sub perl_method_completion_function ($$) {
221 my($text, $state) = @_;
222
223 if ($state) {
224 $i++;
225 } else {
226 # the first call
227 my ($var, $pkg, $sym, $pk);
228 $i = 0; # clear index
229 $var = (substr($attribs->{line_buffer},
230 0, $attribs->{point} - length($text))
231 =~ m/\$([\w:]+)\s*->\s*$/)[0];
232 $pkg = ref eval (($var =~ m/::/) ? "\$$var" : "\$${CWP}::$var");
233 no strict qw(refs);
234 @matches = map { $pk = $_ . '::';
235 grep (/^\w+$/
236 && ($sym = "${pk}$_", defined *$sym{CODE}),
237 keys %$pk);
238 } _search_ISA($pkg);
239 }
240 for (; $i <= $#matches; $i++) {
241 return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
242 }
243 return undef;
244 }
245
246 #
247 # Perl symbol name completion
248 #
249 {
250 my ($prefix, %type, @keyword);
251
252 sub perl_symbol_completion_function ($$) {
253 my($text, $state) = @_;
254
255 if ($state) {
256 $i++;
257 } else {
258 # the first call
259 my ($pre, $pkg, $sym);
260 $i = 0; # clear index
261
262 no strict qw(refs);
263 ($prefix, $pre, $pkg) = ($text =~ m/^((\$#|[\@\$%&])?(.*::)?)/);
264 @matches = grep /::$/, $pkg ? keys %$pkg : keys %::;
265 $pkg = ($CWP eq 'main' ? '::' : $CWP . '::') unless $pkg;
266
267 if ($pre) { # $foo, @foo, $#foo, %foo, &foo
268 @matches = (@matches,
269 grep (/^\w+$/
270 && ($sym = $pkg . $_,
271 defined *$sym{$type{$pre}}),
272 keys %$pkg));
273 } else { # foo
274 @matches = (@matches,
275 !$prefix && @keyword,
276 grep (/^\w+$/
277 && ($sym = $pkg . $_,
278 defined *$sym{CODE}
279 || defined *$sym{FILEHANDLE}
280 ),
281 keys %$pkg));
282 }
283 }
284 my $entry;
285 for (; $i <= $#matches; $i++) {
286 $entry = $prefix . $matches[$i];
287 return $entry if ($entry =~ /^\Q$text/);
288 }
289 return undef;
290 }
291
292 BEGIN {
293 %type = ('$' => 'SCALAR', '*' => 'SCALAR',
294 '@' => 'ARRAY', '$#' => 'ARRAY',
295 '%' => 'HASH',
296 '&' => 'CODE'); # '
297
298 # from perl5.004_02 perlfunc
299 @keyword = qw(
300 chomp chop chr crypt hex index lc lcfirst
301 length oct ord pack q qq
302 reverse rindex sprintf substr tr uc ucfirst
303 y
304
305 m pos quotemeta s split study qr
306
307 abs atan2 cos exp hex int log oct rand sin
308 sqrt srand
309
310 pop push shift splice unshift
311
312 grep join map qw reverse sort unpack
313
314 delete each exists keys values
315
316 binmode close closedir dbmclose dbmopen die
317 eof fileno flock format getc print printf
318 read readdir rewinddir seek seekdir select
319 syscall sysread sysseek syswrite tell telldir
320 truncate warn write
321
322 pack read syscall sysread syswrite unpack vec
323
324 chdir chmod chown chroot fcntl glob ioctl
325 link lstat mkdir open opendir readlink rename
326 rmdir stat symlink umask unlink utime
327
328 caller continue die do dump eval exit goto
329 last next redo return sub wantarray
330
331 caller import local my package use
332
333 defined dump eval formline local my reset
334 scalar undef wantarray
335
336 alarm exec fork getpgrp getppid getpriority
337 kill pipe qx setpgrp setpriority sleep
338 system times wait waitpid
339
340 do import no package require use
341
342 bless dbmclose dbmopen package ref tie tied
343 untie use
344
345 accept bind connect getpeername getsockname
346 getsockopt listen recv send setsockopt shutdown
347 socket socketpair
348
349 msgctl msgget msgrcv msgsnd semctl semget
350 semop shmctl shmget shmread shmwrite
351
352 endgrent endhostent endnetent endpwent getgrent
353 getgrgid getgrnam getlogin getpwent getpwnam
354 getpwuid setgrent setpwent
355
356 endprotoent endservent gethostbyaddr
357 gethostbyname gethostent getnetbyaddr
358 getnetbyname getnetent getprotobyname
359 getprotobynumber getprotoent getservbyname
360 getservbyport getservent sethostent setnetent
361 setprotoent setservent
362
363 gmtime localtime time times
364
365 abs bless chomp chr exists formline glob
366 import lc lcfirst map my no prototype qx qw
367 readline readpipe ref sub sysopen tie tied
368 uc ucfirst untie use
369
370 dbmclose dbmopen
371 );
372 }
373 }
374
375 __END__
376
377 =pod
378
379 Before invoking, this program reads F<~/.perlshrc> and evaluates the
380 content of the file.
381
382 When this program is terminated, the content of the history buffer is
383 saved in a file F<~/.perlsh_history>, and it is read at next
384 invoking.
385
386 =head1 VARIABLES
387
388 You can customize the behavior of C<perlsh> by setting following
389 variables in F<~/.perlshrc>;
390
391 =over 4
392
393 =item C<$PerlSh::PS1>
394
395 The primary prompt string. The following backslash-escaped special
396 characters can be used.
397
398 \h: host name
399 \u: user name
400 \w: package name
401 \!: history number
402
403 The default value is `C<\w[\!]$ >'.
404
405 =item C<$PerlSh::PS2>
406
407 The secondary prompt string. The default value is `C<E<gt> >'.
408
409 =item C<$PerlSh::HISTFILE>
410
411 The name of the file to which the command history is saved. The
412 default value is C<~/.perlsh_history>.
413
414 =item C<$PerlSh::HISTSIZE>
415
416 If not C<undef>, this is the maximum number of commands to remember in
417 the history. The default value is 256.
418
419 =item C<$PerlSh::STRICT>
420
421 If true, restrict unsafe constructs. See C<use strict> in perl man
422 page. The default value is 0;
423
424 =over
425
426 =head1 FILES
427
428 =over 4
429
430 =item F<~/.perlshrc>
431
432 This file is eval-ed at initialization. If a subroutine C<afterinit>
433 is defined in this file, it will be eval-ed after initialization.
434 Here is a sample.
435
436 # -*- mode: perl -*-
437 # decimal to hexa
438 sub h { map { sprintf("0x%x", $_ ) } @_;}
439
440 sub tk {
441 $t->tkRunning(1);
442 use Tk;
443 $mw = MainWindow->new();
444 }
445
446 # for debugging Term::ReadLine::Gnu
447 sub afterinit {
448 *t = \$PerlSh::term;
449 *a = \$PerlSh::attribs;
450 }
451
452 =item F<~/.perlsh_history>
453
454 =item F<~/.inputrc>
455
456 A initialization file for the GNU Readline Library. Refer its manual
457 for details.
458
459 =back
460
461 =head1 SEE ALSO
462
463 Term::ReadLine::Gnu
464
465 GNU Readline Library Manual
466
467 =head1 AUTHOR
468
469 Hiroo Hayashi <hiroo.hayashi@computer.org>
470
471 =cut
+470
-0
eg/pftp less more
0 #! /usr/local/bin/perl
1 #
2 # $Id: pftp,v 1.9 1999-03-20 02:46:02+09 hayashi Exp $
3 #
4 # Copyright (c) 1997,1998,1999 Hiroo Hayashi. All Rights Reserved.
5 #
6 # This program is free software; you can redistribute it and/or
7 # modify it under the same terms as Perl itself.
8
9 =head1 NAME
10
11 pftp - an ftp client with the GNU Readline support
12
13 =head1 SYNOPSIS
14
15 B<pftp> [B<-u>] [B<-g>] [B<-M>] [B<-h>] [B<-d>] [I<host>]
16
17 =head1 DESCRIPTION
18
19 This is an ftp client which has the GNU Readline support. It can
20 complete not only local file name but also remote file name and host
21 name to which login.
22
23 This is a sample program of Perl Term::ReadLine::Gnu module.
24
25 =cut
26
27 use Term::ReadLine;
28 use strict;
29 use Net::Domain qw(hostdomain); # libnet
30 use Net::FTP; # libnet-1.05 or later is recommended
31 use File::Listing; # libwww (for parse_dir)
32 use Getopt::Std;
33 use Cwd; # for getcwd
34
35 use vars qw($AUTOLOAD
36 $opt_d $opt_u $opt_g $opt_M $opt_h);
37
38 sub usage {
39 print STDERR <<"EOM";
40 usage : $0 [-d] [-i] [-u] [-g] [-M] [-h] host
41 -d : debug mode
42 -i : interactive mode (not implemented)
43 -u : disable autologin
44 -g : turn off glob
45 -M : show manual page
46 -h : show this message
47 EOM
48 exit 0;
49 }
50
51 getopts('dugMh') or &usage;
52 &man if $opt_M;
53 &usage if $opt_h;
54
55 #
56 # setup Term::ReadLine::GNU
57 #
58 my $HOSTFILE = ($ENV{HOME} || (getpwuid($<))[7]) . "/.pftp_hosts";
59
60 my $term = Term::ReadLine->new('PFTP');
61 my $attribs = $term->Attribs;
62 $term->ornaments('md,me,,'); # bold face prompt
63
64 #
65 # read hostname to which login
66 #
67 my $host;
68 my @hosts = read_hosts($HOSTFILE);
69 if (@ARGV) {
70 $host = shift;
71 } else {
72 $attribs->{completion_word} = \@hosts;
73 $attribs->{completion_append_character} = '';
74 $attribs->{completion_entry_function} =
75 $attribs->{'list_completion_function'};
76 $host = $term->readline('hostname> ');
77 $host =~ s/^\s+//;
78 $host =~ s/\s+$//;
79 $attribs->{completion_append_character} = ' ';
80 $attribs->{completion_entry_function} = undef;
81 }
82
83 #
84 # make ftp connection
85 #
86 my $ftp = Net::FTP->new($host,
87 Debug => $opt_d);
88 die "$0: cannot connect \`$host\'\n" unless $ftp;
89
90 print STDERR $ftp->message;
91 write_hosts($HOSTFILE, $host, @hosts);
92
93 #
94 # login
95 #
96 my $login = 'anonymous';
97 my $password = (getpwuid($<))[0] . '@' . hostdomain;
98 if ($opt_u) {
99 $login = $term->readline('login name> ', $login);
100
101 # mask typed characters for password
102 $attribs->{redisplay_function} = $attribs->{shadow_redisplay};
103 $password = $term->readline('password> ', $password);
104 undef $attribs->{redisplay_function};
105 }
106
107 $ftp->login($login, $password) or die "$0: cannot login: " . $ftp->message;
108 print STDERR $ftp->message;
109
110 $ftp->binary; # default binary
111 print STDERR $ftp->message;
112
113 my $pwd = $ftp->pwd;
114 print STDERR $ftp->message;
115
116 #
117 # setup completion function
118 #
119 my @ftp_cmd_list = qw(cwd cd pwd ls dir get mget put mput lcd help);
120
121 # completion_display_match_hook is supported by GNU Readline Library
122 # 4.0 and later. Earlier versions ignore it.
123
124 $attribs->{attempted_completion_function} = sub {
125 my ($text, $line, $start, $end) = @_;
126 if (substr($line, 0, $start) =~ /^\s*$/) {
127 $attribs->{completion_word} = \@ftp_cmd_list;
128 undef $attribs->{completion_display_matches_hook};
129 return $term->completion_matches($text,
130 $attribs->{'list_completion_function'});
131 } elsif ($line =~ /^\s*(ls|dir|get|mget)\s/) {
132 $attribs->{completion_display_matches_hook} = \&ftp_display_match_list;
133 return $term->completion_matches($text,
134 \&ftp_filename_completion_function);
135 } elsif ($line =~ /^\s*(cd|cwd)\s/) {
136 $attribs->{completion_display_matches_hook} = \&ftp_display_match_list;
137 return $term->completion_matches($text,
138 \&ftp_dirname_completion_function);
139 } else { # put mput lcd
140 undef $attribs->{completion_display_matches_hook};
141 return (); # local file name completion
142 }
143 };
144
145 #
146 # Command loop
147 #
148 $SIG{INT} = 'IGNORE'; # ignore Control-C
149
150 while (defined($_ = $term->readline("$login\@$host:$pwd> "))) {
151 no strict 'refs';
152 next if /^\s*$/;
153 my ($cmd, @args) = $term->history_tokenize($_);
154 if ($cmd eq 'quit' || $cmd eq 'bye') {
155 last;
156 }
157 my $func = "cmd_" . $cmd;
158 &$func(@args);
159 $attribs->{completion_append_character} = ' ';
160 }
161 $ftp->quit;
162 print STDERR $ftp->message;
163
164 exit (0);
165
166 ########################################################################
167 #
168 # complete remote filename
169 #
170 sub ftp_filename_completion_function ( $$ ) {
171 my($text, $state) = @_;
172 ftp_completion_function($text, $state, 0);
173 }
174
175 sub ftp_dirname_completion_function ( $$ ) {
176 my($text, $state) = @_;
177 ftp_completion_function($text, $state, 1);
178 }
179
180 {
181 my ($i, $file, $dir, $fdir, $cw);
182
183 sub ftp_completion_function ( $$$ ) {
184 my($text, $state, $dironly) = @_;
185 my $entry;
186
187 unless ($state) {
188 $i = 0; # clear counter at the first call
189 ($dir, $file) = ($text =~ m|(.*/)?(.*)$|);
190 $dir = '' unless defined $dir; # to piecify -w
191 $fdir = ($dir =~ m|^/|) ? $dir : "$pwd/$dir"; # full path name
192 $fdir =~ s|//|/|g;
193 $attribs->{completion_append_character} = ' ';
194 return undef unless defined ($cw = rdir($fdir));
195 } else {
196 $i++;
197 }
198 for (; $i <= $#{$cw}; $i++) {
199 if (($entry = $cw->[$i]) =~ /^$file/
200 && !($dironly && ($entry !~ m|/$|))) {
201 $attribs->{completion_append_character} = ''
202 if $entry =~ m|/$|;
203 return ($dir . $entry);
204 }
205 }
206 return undef;
207 }
208 }
209
210 sub ftp_display_match_list {
211 my($matches, $num_matches, $max_length) = @_;
212 map { $_ =~ s|.*/([^/])|\1|; }(@{$matches});
213 $term->display_match_list($matches);
214 $term->forced_update_display;
215 }
216
217 ########################################################################
218
219 sub AUTOLOAD {
220 # tell a lie to Domain.pm
221 goto &SYS_gethostname if $AUTOLOAD =~/SYS_gethostname$/;
222
223 $AUTOLOAD =~ s/.*::cmd_//;
224 warn "command \`$AUTOLOAD\' is not defined or not implemented.\n";
225 }
226
227 my %rdir;
228
229 sub rdir { # get remote dir info and save it in %rdir
230 my $dir = shift;
231 return $rdir{$dir} if defined $rdir{$dir};
232
233 my $d = $ftp->ls('-F', $dir);
234 if ($d) {
235 foreach (@{$d}) {
236 s|.*/(.)|$1|; # remove directory name
237 s/[*@]$//;
238 }
239 return $rdir{$dir} = $d;
240 } else {
241 return undef;
242 }
243 }
244
245 sub cmd_cwd {
246 if ($ftp->cwd(@_)) {
247 $pwd = $ftp->pwd();
248 } else {
249 print STDERR "cwd: cannot chdir to \`$_\'\n"
250 }
251 print STDERR $ftp->message;
252 }
253
254 # Why this does not work?
255 #*cmd_cd = \&cmd_cwd;
256
257 sub cmd_cd {
258 &cmd_cwd;
259 }
260
261 sub cmd_pwd {
262 $pwd = $ftp->pwd();
263 if ($pwd) {
264 print STDERR "$pwd\n";
265 } else {
266 print STDERR "pwd failed.\n";
267 }
268 print STDERR $ftp->message;
269 }
270
271 sub cmd_ls {
272 # strip ls option
273 return &cmd_dir if $_[0] =~ /^-/ && shift =~ /l/;
274
275 my $dir = shift || $pwd;
276 my $d = rdir($dir);
277 if (defined $d) {
278 dump_list($d);
279 } else {
280 print STDERR "ls failed\n";
281 }
282 print STDERR $ftp->message;
283 }
284
285 # from bash-2.0/lib/readline/complete.c:display_matches()
286 # bash-4.0 and later has rl_display_match_list. Ignore it for compativility.
287 sub dump_list {
288 use integer;
289 my @list = sort @{$_[0]};
290 my ($len, $max, $limit, $count, $i, $j, $l, $tmp);
291 my $screenwidth = $ENV{COLUMNS} || 80;
292 $max = 0;
293 foreach (@list) {
294 $len = length;
295 $max = $len if $len > $max;
296 }
297 $max += 2;
298 $limit = $screenwidth / $max;
299 $limit-- if ($limit != 1 && ($limit * $max == $screenwidth));
300 $limit = 1 if $limit == 0;
301 $count = (@list + ($limit - 1))/ $limit;
302 for $i (0..$count - 1) {
303 $l = $i;
304 for $j (0..$limit - 1) {
305 $tmp = $list[$l];
306 last if $l > @list || ! $tmp;
307 print $tmp;
308 print ' ' x ($max - length $tmp) if $j + 1 < $limit;
309 $l += $count;
310 }
311 print "\n";
312 }
313 }
314
315 sub cmd_dir {
316 # strip ls option
317 shift if $_[0] =~ /^-/;
318
319 my $dir = $ftp->dir('-F', @_);
320 print STDERR $ftp->message;
321
322 my @dir;
323 if ($dir) {
324 foreach (@{$dir}) {
325 print STDERR "$_\n";
326
327 my $info = (parse_dir($_, '+0000'))[0]; # GMT
328 next unless $info; # ignore if parse_dir() can not phase.
329 next if $$info[0] =~ m|^\.\.?/$|; # ignore '.' and '..'
330 $$info[0] =~ s|.*/(.)|$1|; # remove directory name
331 $$info[0] =~ s/[*@]$//;
332 push(@dir, $$info[0]);
333 }
334 $rdir{$pwd} = \@dir;
335 } else {
336 print STDERR "dir failed\n";
337 }
338 }
339
340 sub cmd_get {
341 $ftp->get(@_);
342 print STDERR $ftp->message;
343 }
344
345 sub cmd_mget {
346 if ($opt_g) {
347 foreach (@_) {
348 $ftp->get($_);
349 print STDERR $ftp->message;
350 }
351 } else {
352 my $d = $ftp->ls(@_);
353 print STDERR $ftp->message;
354 foreach (sort @{$d}) {
355 $ftp->get($_);
356 print STDERR $ftp->message;
357 }
358 }
359 }
360
361 sub cmd_put {
362 $ftp->put(@_);
363 print STDERR $ftp->message;
364 }
365
366 sub cmd_mput {
367 my $f;
368 foreach $f (@_) {
369 foreach ($opt_g ? $f : glob $f) {
370 $ftp->put($_);
371 print STDERR $ftp->message;
372 }
373 }
374 }
375
376 sub cmd_lcd {
377 chdir $_[0] or warn "cannot chdir to $_[0]: $!\n";
378 printf STDERR "local current directory is \`%s\'\n", getcwd();
379 }
380
381 sub cmd_help {
382 print STDERR "@ftp_cmd_list\n";
383 }
384
385 ################################################################
386 sub read_hosts {
387 my $file = shift;
388 return () unless -f $file;
389 open(F, $file) or die "$0: cannot open file \`$file\'\n";
390 my @l = <F>;
391 close(F);
392 chomp @l;
393 return @l;
394 }
395
396 sub write_hosts {
397 my $file = shift;
398 my $lastline = '';
399 open(F, ">$file") or die "$0: cannot open file \`$file\'\n";
400 foreach (sort @_) {
401 print F ($_, "\n") if $_ ne $lastline;
402 $lastline = $_;
403 }
404 close(F);
405 }
406
407 ################################################################
408 # show man page
409 sub man {
410 my $pager = $ENV{'PAGER'} || 'more';
411 exec "pod2man $0|nroff -man|$pager";
412 die "cannot exec pod2man, nroff, or $pager : $!\n";
413 }
414
415 __END__
416
417 =pod
418
419 =head1 OPTIONS
420
421 =over 4
422
423 =item B<-u>
424
425 disable autologin.
426
427 =item B<-g>
428
429 turn off glob.
430
431 =item B<-h>
432
433 show usage.
434
435 =item B<-M>
436
437 show thie manual.
438
439 =item B<-d>
440
441 debug mode.
442
443 =item I<host>
444
445 remote host name.
446
447 =back
448
449 =head1 FILES
450
451 =over 4
452
453 =item I<~/.pftp_hosts>
454
455 This file contains the list of host names. These name are used for
456 completing of remote host name. If the host name which you login is
457 not contained in this file, it will be added automatically.
458
459 =back
460
461 =head1 AUTHOR
462
463 Hiroo Hayashi <hiroo.hayashi@computer.org>
464
465 =head1 BUGS
466
467 Commands which the author does not know are not supported.
468
469 =cut
+127
-0
eg/ptksh+ less more
0 #!/usr/local/bin/perl -w
1 #
2 # $Id: ptksh+,v 1.5 1997/04/01 17:15:34 ach Exp ach $
3 #
4 # POD documentation after __END__
5
6 # This program is contributed by Achim Bohnet. It demonstrates how to
7 # use the callback functions in the GNU Readline Library. This script
8 # is essetially equivalent with executing the following lines in
9 # `eg/perlsh';
10 # $PerlSh::term->tkRunning(1);
11 # use Tk;
12 # $mw = MainWindow->new();
13 #
14 # Hiroo Hayashi
15
16 require 5.003_92;
17
18 use Tk;
19
20 # Bug: Require script does not work with all possibilities of
21 # missing/existing new MainWindow and MainLoop. Therefore
22 # I have disabled it.
23 # Mainloop in script would be the end. No readline :-(
24 #require shift @ARGV if (@ARGV);
25
26
27 package Tk::RL;
28 use Tk;
29 use Term::ReadLine;
30
31 $name = 'ptksh+';
32
33 $mw = MainWindow->new() unless ($mw = Tk::Exists 'MainWindow');
34 $mw->title($name);
35 $mw->iconname($name);
36 $mw->protocol('WM_DELETE_WINDOW' => \&quit);
37
38
39 ##### Gnu Readline Stuff #####
40 my $term = new Term::ReadLine $name;
41 my $attribs = $term->Attribs;
42
43 $term->callback_handler_install("$name> ", \&doline);
44
45 $mw->fileevent(STDIN,'readable',
46 $attribs->{callback_read_char});
47
48 sub quit {
49 $mw->fileevent(STDIN,'readable','');
50 $term->callback_handler_remove();
51 $mw->destroy;
52 }
53
54 my $outstream = $attribs->{outstream};
55 sub doline {
56 my $line = shift;
57
58 if (defined $line) {
59 if ($line =~ /^p\s(.*)$/) {
60 $line = "print $1, \"!\\n\";";
61 }
62
63 eval "{package main; $line }";
64 print $outstream "$@\n" if $@;
65 $term->add_history($line) if $line ne "";
66 $attribs->{line_buffer} = ''; # needed for eval errors
67 } else {
68 quit() unless defined $line;
69 }
70 }
71
72 # To test if Tk is not blocked: Tk::RL::tk_active<return>
73 sub tk_active {
74 print STDERR "I'm working behing the scene\n";
75 $mw->after(1500,\&tk_active);
76 }
77 #$mw->after(1500,\&tk_active);
78
79
80 package main;
81
82 # be gentle if 'required' script defined $mw;
83 $mw = $Tk::RL::mw if not defined $mw;
84
85 MainLoop;
86 print "\n";
87
88 __END__
89
90 =head1 NAME
91
92 ptksh+ - Simple perl/Tk shell that uses the Gnu Readline features
93
94 =head1 SYNOPSIS
95
96 % ptksh+
97 ptksh+> $b=$mw->Button(-text=>'hello',-command=>sub{print STDERR 'hello'})
98 ptksh+> $b->pack;
99 ptksh+> ...
100 ptksh+> ^D
101 %
102
103 =head1 DESCRIPTION
104
105 This (very) simple perl/Tk shell allows you to enter perl/Tk commands
106 interactively.
107 Additionally it supports command line editing and keeps a history
108 of previously entered commands. It requires C<Term-Readline-Gnu>
109 to be installed.
110
111 You can exit ptksh+ with ^D or using your Window Manager 'Close'
112 item.
113
114 =head1 SEE ALSO
115
116 Term::Readline, Term::Readline::Gnu, Tk, perldebug
117
118 =head1 AUTHOR
119
120 Achim Bohnet <F<ach@mpe.mpg.de>>, URL:L<http://www.xray.mpe.mpg.de/~ach/>
121
122 Copyright (c) 1996-1997 Achim Bohnet. All rights reserved. This program
123 is free software; you can redistribute it and/or modify it under the same
124 terms as Perl itself.
125
126 =cut
+286
-0
ppport.h less more
0
1 #ifndef _P_P_PORTABILITY_H_
2 #define _P_P_PORTABILITY_H_
3
4 /* Perl/Pollution/Portability Version 1.0007 */
5
6 /* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
7 distributed under the same license as any version of Perl. */
8
9 /* For the latest version of this code, please retreive the Devel::PPPort
10 module from CPAN, contact the author at <kjahds@kjahds.com>, or check
11 with the Perl maintainers. */
12
13 /* If you needed to customize this file for your project, please mention
14 your changes, and visible alter the version number. */
15
16
17 /*
18 In order for a Perl extension module to be as portable as possible
19 across differing versions of Perl itself, certain steps need to be taken.
20 Including this header is the first major one, then using dTHR is all the
21 appropriate places and using a PL_ prefix to refer to global Perl
22 variables is the second.
23 */
24
25
26 /* If you use one of a few functions that were not present in earlier
27 versions of Perl, please add a define before the inclusion of ppport.h
28 for a static include, or use the GLOBAL request in a single module to
29 produce a global definition that can be referenced from the other
30 modules.
31
32 Function: Static define: Extern define:
33 newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
34
35 */
36
37
38 /* To verify whether ppport.h is needed for your module, and whether any
39 special defines should be used, ppport.h can be run through Perl to check
40 your source code. Simply say:
41
42 perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
43
44 The result will be a list of patches suggesting changes that should at
45 least be acceptable, if not necessarily the most efficient solution, or a
46 fix for all possible problems. It won't catch where dTHR is needed, and
47 doesn't attempt to account for global macro or function definitions,
48 nested includes, typemaps, etc.
49
50 In order to test for the need of dTHR, please try your module under a
51 recent version of Perl that has threading compiled-in.
52
53 */
54
55
56 /*
57 #!/usr/bin/perl
58 @ARGV = ("*.xs") if !@ARGV;
59 %badmacros = %funcs = %macros = (); $replace = 0;
60 foreach (<DATA>) {
61 $funcs{$1} = 1 if /Provide:\s+(\S+)/;
62 $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
63 $replace = $1 if /Replace:\s+(\d+)/;
64 $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
65 $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
66 }
67 foreach $filename (map(glob($_),@ARGV)) {
68 unless (open(IN, "<$filename")) {
69 warn "Unable to read from $file: $!\n";
70 next;
71 }
72 print "Scanning $filename...\n";
73 $c = ""; while (<IN>) { $c .= $_; } close(IN);
74 $need_include = 0; %add_func = (); $changes = 0;
75 $has_include = ($c =~ /#.*include.*ppport/m);
76
77 foreach $func (keys %funcs) {
78 if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
79 if ($c !~ /\b$func\b/m) {
80 print "If $func isn't needed, you don't need to request it.\n" if
81 $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
82 } else {
83 print "Uses $func\n";
84 $need_include = 1;
85 }
86 } else {
87 if ($c =~ /\b$func\b/m) {
88 $add_func{$func} =1 ;
89 print "Uses $func\n";
90 $need_include = 1;
91 }
92 }
93 }
94
95 if (not $need_include) {
96 foreach $macro (keys %macros) {
97 if ($c =~ /\b$macro\b/m) {
98 print "Uses $macro\n";
99 $need_include = 1;
100 }
101 }
102 }
103
104 foreach $badmacro (keys %badmacros) {
105 if ($c =~ /\b$badmacro\b/m) {
106 $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
107 print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
108 $need_include = 1;
109 }
110 }
111
112 if (scalar(keys %add_func) or $need_include != $has_include) {
113 if (!$has_include) {
114 $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
115 "#include \"ppport.h\"\n";
116 $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
117 } elsif (keys %add_func) {
118 $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
119 $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
120 }
121 if (!$need_include) {
122 print "Doesn't seem to need ppport.h.\n";
123 $c =~ s/^.*#.*include.*ppport.*\n//m;
124 }
125 $changes++;
126 }
127
128 if ($changes) {
129 open(OUT,">/tmp/ppport.h.$$");
130 print OUT $c;
131 close(OUT);
132 open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
133 while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
134 close(DIFF);
135 unlink("/tmp/ppport.h.$$");
136 } else {
137 print "Looks OK\n";
138 }
139 }
140 __DATA__
141 */
142
143 #ifndef PERL_REVISION
144 # ifndef __PATCHLEVEL_H_INCLUDED__
145 # include "patchlevel.h"
146 # endif
147 # ifndef PERL_REVISION
148 # define PERL_REVISION (5)
149 /* Replace: 1 */
150 # define PERL_VERSION PATCHLEVEL
151 # define PERL_SUBVERSION SUBVERSION
152 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
153 /* Replace: 0 */
154 # endif
155 #endif
156
157 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
158
159 #ifndef ERRSV
160 # define ERRSV perl_get_sv("@",FALSE)
161 #endif
162
163 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
164 /* Replace: 1 */
165 # define PL_sv_undef sv_undef
166 # define PL_sv_yes sv_yes
167 # define PL_sv_no sv_no
168 # define PL_na na
169 # define PL_stdingv stdingv
170 # define PL_hints hints
171 # define PL_curcop curcop
172 # define PL_curstash curstash
173 # define PL_copline copline
174 # define PL_Sv Sv
175 /* Replace: 0 */
176 #endif
177
178 #ifndef dTHR
179 # ifdef WIN32
180 # define dTHR extern int Perl___notused
181 # else
182 # define dTHR extern int errno
183 # endif
184 #endif
185
186 #ifndef boolSV
187 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
188 #endif
189
190 #ifndef gv_stashpvn
191 # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
192 #endif
193
194 #ifndef newSVpvn
195 # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
196 #endif
197
198 #ifndef newRV_inc
199 /* Replace: 1 */
200 # define newRV_inc(sv) newRV(sv)
201 /* Replace: 0 */
202 #endif
203
204 #ifndef newRV_noinc
205 # ifdef __GNUC__
206 # define newRV_noinc(sv) \
207 ({ \
208 SV *nsv = (SV*)newRV(sv); \
209 SvREFCNT_dec(sv); \
210 nsv; \
211 })
212 # else
213 # if defined(CRIPPLED_CC) || defined(USE_THREADS)
214 static SV * newRV_noinc (SV * sv)
215 {
216 SV *nsv = (SV*)newRV(sv);
217 SvREFCNT_dec(sv);
218 return nsv;
219 }
220 # else
221 # define newRV_noinc(sv) \
222 ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
223 # endif
224 # endif
225 #endif
226
227 /* Provide: newCONSTSUB */
228
229 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
230 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
231
232 #if defined(NEED_newCONSTSUB)
233 static
234 #else
235 extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
236 #endif
237
238 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
239 void
240 newCONSTSUB(stash,name,sv)
241 HV *stash;
242 char *name;
243 SV *sv;
244 {
245 U32 oldhints = PL_hints;
246 HV *old_cop_stash = PL_curcop->cop_stash;
247 HV *old_curstash = PL_curstash;
248 line_t oldline = PL_curcop->cop_line;
249 PL_curcop->cop_line = PL_copline;
250
251 PL_hints &= ~HINT_BLOCK_SCOPE;
252 if (stash)
253 PL_curstash = PL_curcop->cop_stash = stash;
254
255 newSUB(
256
257 #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
258 /* before 5.003_22 */
259 start_subparse(),
260 #else
261 # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
262 /* 5.003_22 */
263 start_subparse(0),
264 # else
265 /* 5.003_23 onwards */
266 start_subparse(FALSE, 0),
267 # endif
268 #endif
269
270 newSVOP(OP_CONST, 0, newSVpv(name,0)),
271 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
272 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
273 );
274
275 PL_hints = oldhints;
276 PL_curcop->cop_stash = old_cop_stash;
277 PL_curstash = old_curstash;
278 PL_curcop->cop_line = oldline;
279 }
280 #endif
281
282 #endif /* newCONSTSUB */
283
284
285 #endif /* _P_P_PORTABILITY_H_ */
+3
-0
t/button.pl less more
0 my $b;
1 $b=$mw->Button(-text=>'hello',-command=>sub{print $OUT 'hello'});
2 $b->pack;
+102
-0
t/callback.t less more
0 # -*- perl -*-
1 # callback.t - Test script for Term::ReadLine:GNU callback function
2 #
3 # $Id: callback.t,v 1.6 2003-03-16 00:22:39-05 hiroo Exp hiroo $
4 #
5 # Copyright (c) 2000 Hiroo Hayashi. All rights reserved.
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the same terms as Perl itself.
9
10 BEGIN {
11 print "1..7\n"; $n = 1;
12 $ENV{PERL_RL} = 'Gnu'; # force to use Term::ReadLine::Gnu
13 }
14 END {print "not ok 1\tfail to loading\n" unless $loaded;}
15
16 my $verbose = defined @ARGV && ($ARGV[0] eq 'verbose');
17
18 $^W = 1; # perl -w
19 use strict;
20 use vars qw($loaded $n);
21 eval "use ExtUtils::testlib;" or eval "use lib './blib';";
22 use Term::ReadLine;
23
24 $loaded = 1;
25 print "ok 1\tloading\n"; $n++;
26
27 ########################################################################
28 # test new method
29
30 my $term = new Term::ReadLine 'ReadLineTest';
31 print defined $term ? "ok $n\n" : "not ok $n\n"; $n++;
32
33 my $attribs = $term->Attribs;
34 print defined $attribs ? "ok $n\n" : "not ok $n\n"; $n++;
35
36 my ($version) = $attribs->{library_version} =~ /(\d+\.\d+)/;
37
38 ########################################################################
39 # check Tk is installed
40 #disable the warning, "Too late to run INIT block at..."
41 $^W = 0;
42 if (eval "use Tk; 1") {
43 print "ok $n\tuse Tk\n"; $n++;
44 } else {
45 print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
46 print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
47 print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
48 print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
49 exit 0;
50 }
51 $^W = 1;
52
53 ########################################################################
54 my ($IN, $OUT);
55 if ($verbose) {
56 # wait for Perl Tk script from tty
57 $IN = $attribs->{instream};
58 $OUT = $attribs->{outstream};
59 } else {
60 # test automatically
61 # to surpress warning on GRL 4.2a (and above?).
62 $attribs->{prep_term_function} = sub {} if ($version > 4.1);
63
64 # open(IN, 't/button.pl') or die "cannot open 't/button.pl': $!\n";
65 # $IN = \*IN;
66 # old Perl did not work with the next line...
67 $IN = \*DATA; # does not work. Why?
68 open(NULL, '>/dev/null') or die "cannot open \`/dev/null\': $!\n";
69 $attribs->{outstream} = $OUT = \*NULL;
70 }
71
72 ########################################################################
73 my $mw;
74 $mw = MainWindow->new();
75 $mw->protocol('WM_DELETE_WINDOW' => \&quit);
76
77 $attribs->{instream} = $IN;
78 $mw->fileevent($IN, 'readable', $attribs->{callback_read_char});
79 print "ok $n\tcallback_read_char\n"; $n++;
80
81 $term->callback_handler_install("> ", sub {
82 my $line = shift;
83 quit() unless defined $line;
84 eval $line;
85 print $OUT "$@\n" if $@;
86 });
87 print "ok $n\tcallback_handler_install\n"; $n++;
88
89 &MainLoop;
90
91 sub quit {
92 $mw->fileevent($IN, 'readable', '');
93 $term->callback_handler_remove();
94 $mw->destroy;
95 print "ok $n\n"; $n++;
96 exit 0;
97 }
98
99 __END__
100 $b=$mw->Button(-text=>'hello',-command=>sub{print $OUT 'hello'})
101 $b->pack;
+0
-0
t/comptest/0123 less more
(New empty file)
+0
-0
t/comptest/012345 less more
(New empty file)
+0
-0
t/comptest/023456 less more
(New empty file)
+2
-0
t/comptest/README less more
0 This directory is for filename completion test.
1 The size of most of files in this directory is zero.
+0
-0
t/comptest/a_b less more
(New empty file)
+476
-0
t/history.t less more
0 # -*- perl -*-
1 # history.t --- Term::ReadLine:GNU History Library Test Script
2 #
3 # $Id: history.t,v 1.9 2003-03-16 00:22:39-05 hiroo Exp hiroo $
4 #
5 # Copyright (c) 2002 Hiroo Hayashi. All rights reserved.
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the same terms as Perl itself.
9
10 # Before `make install' is performed this script should be runnable with
11 # `make test'. After `make install' it should work as `perl t/history.t'
12
13 BEGIN {
14 print "1..82\n"; $n = 1;
15 $ENV{PERL_RL} = 'Gnu'; # force to use Term::ReadLine::Gnu
16 }
17 END {print "not ok $n\n" unless $loaded;}
18
19 $^W = 1; # perl -w
20 use strict;
21 use vars qw($loaded $n);
22 eval "use ExtUtils::testlib;" or eval "use lib './blib';";
23 use Term::ReadLine;
24 sub show_indices;
25
26 $loaded = 1;
27 print "ok $n\n"; $n++;
28
29 # Perl-5.005 and later has Test.pm, but I define this here to support
30 # older version.
31 my $res;
32 my $ok = 1;
33 sub ok {
34 my $what = shift || '';
35
36 if ($res) {
37 print "ok $n\t$what\n";
38 } else {
39 print "not ok $n\t$what";
40 print @_ ? "\t@_\n" : "\n";
41 $ok = 0;
42 }
43 $n++;
44 }
45
46 ########################################################################
47 # test new method
48
49 my $t = new Term::ReadLine 'ReadLineTest';
50 print defined $t ? "ok $n\n" : "not ok $n\n"; $n++;
51
52 my $OUT = $t->OUT || \*STDOUT;
53
54 ########################################################################
55 # test ReadLine method
56
57 if ($t->ReadLine eq 'Term::ReadLine::Gnu') {
58 print "ok $n\n";
59 } else {
60 print "not ok $n\n";
61 print $OUT ("Package name should be \`Term::ReadLine::Gnu\', but it is \`",
62 $t->ReadLine, "\'\n");
63 }
64 $n++;
65
66 ########################################################################
67 # test Attribs method
68 use vars qw($attribs);
69
70 $attribs = $t->Attribs;
71 print defined $attribs ? "ok $n\n" : "not ok $n\n"; $n++;
72
73 my ($version) = $attribs->{library_version} =~ /(\d+\.\d+)/;
74
75 ########################################################################
76 # 2.3.1 Initializing History and State Management
77
78 # test using_history
79 # This is verbose since 'new' has already initialized the GNU history library.
80 $t->using_history;
81
82 # history_get_history_state!!!, history_set_history_state!!!
83
84 # check the values of initialized variables
85 print $attribs->{history_base} == 1
86 ? "ok $n\n" : "not ok $n\n"; $n++;
87 print $attribs->{history_length} == 0
88 ? "ok $n\n" : "not ok $n\n"; $n++;
89 print $attribs->{max_input_history} == 0
90 ? "ok $n\n" : "not ok $n\n"; $n++;
91 print $attribs->{history_expansion_char} eq '!'
92 ? "ok $n\n" : "not ok $n\n"; $n++;
93 print $attribs->{history_subst_char} eq '^'
94 ? "ok $n\n" : "not ok $n\n"; $n++;
95 print $attribs->{history_comment_char} eq "\0"
96 ? "ok $n\n" : "not ok $n\n"; $n++;
97 if ($version > 4.2 - 0.01) {
98 $res = $attribs->{history_word_delimiters} eq " \t\n;&()|<>";
99 ok('history_word_delimiters');
100 } else {
101 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
102 $n++;
103 }
104 print $attribs->{history_no_expand_chars} eq " \t\n\r="
105 ? "ok $n\n" : "not ok $n\n"; $n++;
106 print ! defined $attribs->{history_search_delimiter_chars}
107 ? "ok $n\n" : "not ok $n\n"; $n++;
108 print $attribs->{history_quotes_inhibit_expansion} == 0
109 ? "ok $n\n" : "not ok $n\n"; $n++;
110 print ! defined $attribs->{history_inhibit_expansion_function}
111 ? "ok $n\n" : "not ok $n\n"; $n++;
112
113 ########################################################################
114 # 2.3.2 History List Management
115
116 my @list_set;
117 # default value of `history_base' is 1
118 @list_set = qw(one two two three);
119 show_indices;
120
121 # test SetHistory(), GetHistory()
122 $t->SetHistory(@list_set);
123 print cmp_list(\@list_set, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n"; $n++;
124 show_indices;
125
126 # test add_history()
127 $t->add_history('four');
128 push(@list_set, 'four');
129 print cmp_list(\@list_set, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n"; $n++;
130 show_indices;
131
132 # test remove_history()
133 $t->remove_history(2);
134 splice(@list_set, 2, 1);
135 print cmp_list(\@list_set, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n"; $n++;
136 show_indices;
137
138 # test replace_history_entry()
139 $t->replace_history_entry(3, 'daarn');
140 splice(@list_set, 3, 1, 'daarn');
141 print cmp_list(\@list_set, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n"; $n++;
142 show_indices;
143
144 # stifle_history
145 print $t->history_is_stifled == 0 ? "ok $n\n" : "not ok $n\n"; $n++;
146 $t->stifle_history(3);
147 print($t->history_is_stifled == 1
148 && $attribs->{history_length} == 3 && $attribs->{max_input_history} == 3
149 ? "ok $n\n" : "not ok $n\n"); $n++;
150 #print "@{[$t->GetHistory]}\n";
151 show_indices;
152
153 # history_is_stifled()
154 $t->add_history('five');
155 print($t->history_is_stifled == 1 && $attribs->{history_length} == 3
156 ? "ok $n\n" : "not ok $n\n"); $n++;
157 show_indices;
158
159 # unstifle_history()
160 $t->unstifle_history;
161 print($t->history_is_stifled == 0 && $attribs->{history_length} == 3
162 ? "ok $n\n" : "not ok $n\n"); $n++;
163 #print "@{[$t->GetHistory]}\n";
164 show_indices;
165
166 # history_is_stifled()
167 $t->add_history('six');
168 print($t->history_is_stifled == 0 && $attribs->{history_length} == 4
169 ? "ok $n\n" : "not ok $n\n"); $n++;
170 show_indices;
171
172 # clear_history()
173 $t->clear_history;
174 print ($attribs->{history_length} == 0 ? "ok $n\n" : "not ok $n\n"); $n++;
175 show_indices;
176
177 ########################################################################
178 # 2.3.3 Information About the History List
179
180 $attribs->{history_base} = 0;
181 show_indices;
182 @list_set = qw(zero one two three four);
183 $t->stifle_history(4);
184 show_indices;
185 $t->SetHistory(@list_set);
186 show_indices;
187
188 # history_list()
189 # history_list() routine emulates history_list() function in
190 # GNU Readline Library.
191 splice(@list_set, 0, 1);
192 print cmp_list(\@list_set, [$t->history_list])
193 ? "ok $n\n" : "not ok $n\n"; $n++;
194 show_indices;
195
196 # at first where_history() returns 0
197 print $t->where_history == 0 ? "ok $n\n" : "not ok $n\n"; $n++;
198
199 # current_history()
200 # history_base + 0 = 1
201 print $t->current_history eq 'one' ? "ok $n\n" : "not ok $n\n"; $n++;
202
203 # history_total_bytes()
204 print $t->history_total_bytes == 15 ? "ok $n\n" : "not ok $n\n"; $n++;
205
206 ########################################################################
207 # 2.3.4 Moving Around the History List
208
209 # history_set_pos()
210 $t->history_set_pos(2);
211 print $t->where_history == 2 ? "ok $n\n" : "not ok $n\n"; $n++;
212 # history_base + 2 = 3
213 print $t->current_history eq 'three' ? "ok $n\n" : "not ok $n\n"; $n++;
214 show_indices;
215
216 $t->history_set_pos(10000); # should be ingored
217 print $t->where_history == 2 ? "ok $n\n" : "not ok $n\n"; $n++;
218
219 # previous_history()
220 print $t->previous_history eq 'two' ? "ok $n\n" : "not ok $n\n"; $n++;
221 print $t->where_history == 1 ? "ok $n\n" : "not ok $n\n"; $n++;
222 show_indices;
223 print $t->previous_history eq 'one' ? "ok $n\n" : "not ok $n\n"; $n++;
224 show_indices;
225 $^W = 0; # returns NULL
226 print $t->previous_history eq '' ? "ok $n\n" : "not ok $n\n"; $n++;
227 $^W = 1;
228 show_indices;
229
230 # next_history()
231 print $t->next_history eq 'two' ? "ok $n\n" : "not ok $n\n"; $n++;
232 show_indices;
233 print $t->next_history eq 'three' ? "ok $n\n" : "not ok $n\n"; $n++;
234 show_indices;
235 print $t->next_history eq 'four' ? "ok $n\n" : "not ok $n\n"; $n++;
236 show_indices;
237 $^W = 0; # returns NULL
238 print $t->next_history eq '' ? "ok $n\n" : "not ok $n\n"; $n++;
239 $^W = 1;
240 print $t->where_history == 4 ? "ok $n\n" : "not ok $n\n"; $n++;
241 show_indices;
242
243
244 ########################################################################
245 # 2.3.5 Searching the History List
246
247 @list_set = ('red yellow', 'green red', 'yellow blue', 'green blue');
248 $t->SetHistory(@list_set);
249
250 $t->history_set_pos(1);
251 #show_indices;
252
253 # history_search()
254 print($t->history_search('red', -1) == 6 && $t->where_history == 1
255 ? "ok $n\n" : "not ok $n\n"); $n++;
256 print($t->history_search('blue', -1) == -1 && $t->where_history == 1
257 ? "ok $n\n" : "not ok $n\n"); $n++;
258 print($t->history_search('yellow', -1) == 4 && $t->where_history == 0
259 ? "ok $n\n" : "not ok $n\n"); $n++;
260
261 print($t->history_search('red', 1) == 0 && $t->where_history == 0
262 ? "ok $n\n" : "not ok $n\n"); $n++;
263 print($t->history_search('blue', 1) == 7 && $t->where_history == 2
264 ? "ok $n\n" : "not ok $n\n"); $n++;
265 print($t->history_search('red', 1) == -1 && $t->where_history == 2
266 ? "ok $n\n" : "not ok $n\n"); $n++;
267
268 print($t->history_search('red') == 6 && $t->where_history == 1
269 ? "ok $n\n" : "not ok $n\n"); $n++;
270
271 # history_search_prefix()
272 print($t->history_search_prefix('red', -1) == 0
273 && $t->where_history == 0 ? "ok $n\n" : "not ok $n\n"); $n++;
274 print($t->history_search_prefix('green', 1) == 0
275 && $t->where_history == 1 ? "ok $n\n" : "not ok $n\n"); $n++;
276 print($t->history_search_prefix('red', 1) == -1
277 && $t->where_history == 1 ? "ok $n\n" : "not ok $n\n"); $n++;
278 print($t->history_search_prefix('red') == 0
279 && $t->where_history == 0 ? "ok $n\n" : "not ok $n\n"); $n++;
280
281 # history_search_pos()
282 $t->history_set_pos(3);
283 print($t->history_search_pos('red', -1, 1) == 1
284 ? "ok $n\n" : "not ok $n\n"); $n++;
285 print($t->history_search_pos('red', -1, 3) == 1
286 ? "ok $n\n" : "not ok $n\n"); $n++;
287 print($t->history_search_pos('black', -1, 3) == -1
288 ? "ok $n\n" : "not ok $n\n"); $n++;
289 print($t->history_search_pos('yellow', -1) == 2
290 ? "ok $n\n" : "not ok $n\n"); $n++;
291 print($t->history_search_pos('green') == 3
292 ? "ok $n\n" : "not ok $n\n"); $n++;
293 print($t->history_search_pos('yellow', 1, 1) == 2
294 ? "ok $n\n" : "not ok $n\n"); $n++;
295 print($t->history_search_pos('yellow', 1) == -1
296 ? "ok $n\n" : "not ok $n\n"); $n++;
297 print($t->history_search_pos('red', 1, 2) == -1
298 ? "ok $n\n" : "not ok $n\n"); $n++;
299
300 ########################################################################
301 # 2.3.6 Managing the History File
302
303 $t->stifle_history(undef);
304 my $hfile = '.history_test';
305 my @list_write = $t->GetHistory();
306 $t->WriteHistory($hfile) || warn "error at write_history: $!\n";
307
308 $t->SetHistory(); # clear history list
309 print ! $t->GetHistory ? "ok $n\n" : "not ok $n\n"; $n++;
310
311 $t->ReadHistory($hfile) || warn "error at read_history: $!\n";
312 print cmp_list(\@list_write, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n";
313 $n++;
314
315 @list_write = qw(0 1 2 3 4);
316 $t->SetHistory(@list_write);
317 # write_history()
318 ! $t->write_history($hfile) || warn "error at write_history: $!\n";
319 $t->SetHistory(); # clear history list
320 # read_history()
321 ! $t->read_history($hfile) || warn "error at read_history: $!\n";
322 print cmp_list(\@list_write, [$t->GetHistory]) ? "ok $n\n" : "not ok $n\n";
323 $n++;
324
325 # read_history() with range
326 ! $t->read_history($hfile, 1, 3) || warn "error at read_history: $!\n";
327 print cmp_list([0,1,2,3,4,1,2], [$t->GetHistory])
328 ? "ok $n\n" : "not ok $n\n"; $n++;
329 #print "@{[$t->GetHistory]}\n";
330 ! $t->read_history($hfile, 2, -1) || warn "error at read_history: $!\n";
331 print cmp_list([0,1,2,3,4,1,2,2,3,4], [$t->GetHistory])
332 ? "ok $n\n" : "not ok $n\n"; $n++;
333 #print "@{[$t->GetHistory]}\n";
334
335 # append_history()
336 ! $t->append_history(5, $hfile) || warn "error at append_history: $!\n";
337 $t->SetHistory(); # clear history list
338 ! $t->read_history($hfile) || warn "error at read_history: $!\n";
339 print cmp_list([0,1,2,3,4,1,2,2,3,4], [$t->GetHistory])
340 ? "ok $n\n" : "not ok $n\n"; $n++;
341 #print "@{[$t->GetHistory]}\n";
342
343 # history_truncate_file()
344 $t->history_truncate_file($hfile, 6); # always returns 0
345 $t->SetHistory(); # clear history list
346 ! $t->read_history($hfile) || warn "error at read_history: $!\n";
347 print cmp_list([4,1,2,2,3,4], [$t->GetHistory])
348 ? "ok $n\n" : "not ok $n\n"; $n++;
349 #print "@{[$t->GetHistory]}\n";
350
351 ########################################################################
352 # 2.3.7 History Expansion
353
354 my ($string, $ret, @ret, $exp, @exp);
355
356 @list_set = ('red yellow', 'blue red', 'yellow blue', 'green blue');
357 $t->SetHistory(@list_set);
358 $t->history_set_pos(2);
359
360 # history_expand()
361 #print "${\($t->history_expand('!!'))}";
362 # !! : last entry of the history list
363 print $t->history_expand('!!') eq 'green blue'
364 ? "ok $n\n" : "not ok $n\n"; $n++;
365 print $t->history_expand('!yel') eq 'yellow blue'
366 ? "ok $n\n" : "not ok $n\n"; $n++;
367
368 ($ret, $string) = $t->history_expand('!red');
369 print $ret == 1 && $string eq 'red yellow' ? "ok $n\n" : "not ok $n\n"; $n++;
370
371 # get_history_event()
372 my ($text, $cindex);
373 # 1 2
374 # 012345678901234567890123
375 $string = '!-2 !?red? "!blu" white';
376
377 # !-2: 2 line before
378 ($text, $cindex) = $t->get_history_event($string, 0);
379 $res = $cindex == 3 && $text eq 'yellow blue'; ok('get_history_event');
380 #print "$cindex,$text\n";
381
382 # non-event designator
383 ($text, $cindex) = $t->get_history_event($string, 3);
384 $res = $cindex == 3 && ! defined $text; ok;
385 #print "$cindex,$text\n";
386
387 # The following 2 test may fail with readline-4.3 with some locale
388 # setting. It comes from bug of the Readline Library. I sent a patch
389 # to the maintainer. `LANG=C make test' should work.
390 # !?red?: line including `red'
391 ($text, $cindex) = $t->get_history_event($string, 4);
392 $res = $cindex == 10 && $text eq 'blue red'; ok;
393 #print "$cindex,$text\n";
394
395 # "!?blu": line including `blu'
396 ($text, $cindex) = $t->get_history_event($string, 12, '"');
397 $res = $cindex == 16 && $text eq 'blue red'; ok;
398 #print "$cindex,$text\n";
399
400
401 # history_tokenize(), history_arg_extract()
402
403 $string = ' foo "double quoted"& \'single quoted\' (paren)';
404 # for history_tokenize()
405 @exp = ('foo', '"double quoted"', '&', '\'single quoted\'', '(', 'paren', ')');
406 # for history_arg_extract()
407 $exp = "@exp";
408
409 @ret = $t->history_tokenize($string);
410 print cmp_list(\@ret, \@exp) ? "ok $n\n" : "not ok $n\n"; $n++;
411
412 $ret = $t->history_arg_extract($string, 0, '$'); #') comments for font-lock;
413 print $ret eq $exp ? "ok $n\n" : "not ok $n\n"; $n++;
414 $ret = $t->history_arg_extract($string, 0);
415 print $ret eq $exp ? "ok $n\n" : "not ok $n\n"; $n++;
416 $ret = $t->history_arg_extract($string);
417 print $ret eq $exp ? "ok $n\n" : "not ok $n\n"; $n++;
418 $_ = $string;
419 $ret = $t->history_arg_extract;
420 print $ret eq $exp ? "ok $n\n" : "not ok $n\n"; $n++;
421
422 ########################################################################
423 # 2.4 History Variables
424
425 # history_base, history_length, max_input_history are tested above
426
427 # history_expansion_char!!!, history_subst_char!!!, history_comment_char!!!,
428 # history_word_delimiters!!!, history_no_expand_chars!!!
429
430 # history_inhibit_expansion_function
431 @list_set = ('red yellow', 'blue red', 'yellow blue', 'green blue');
432 $t->SetHistory(@list_set);
433 $t->history_set_pos(2);
434 $attribs->{history_inhibit_expansion_function} = sub {
435 my ($string, $index) = @_;
436 substr($string, $index + 1, 1) eq '!'; # inhibit expanding '!!'
437 };
438
439 print $t->history_expand('!!') eq '!!'
440 ? "ok $n\n" : "not ok $n\n"; $n++;
441 print $t->history_expand(' !r') eq ' red yellow'
442 ? "ok $n\n" : "not ok $n\n"; $n++;
443 print $t->history_expand('!! !y') eq 'green blue yellow blue'
444 ? "ok $n\n" : "not ok $n\n"; $n++;
445
446 end_of_test:
447
448 exit 0;
449
450 ########################################################################
451 # subroutines
452
453 # compare lists
454 sub cmp_list {
455 ($a, $b) = @_;
456 my @a = @$a;
457 my @b = @$b;
458 return undef if $#a ne $#b;
459 for (0..$#a) {
460 return undef if $a[$_] ne $b[$_];
461 }
462 return 1;
463 }
464
465 # debugging support
466 sub show_indices {
467 return;
468 printf("where_history: %d ", $t->where_history);
469 # printf("current_history(): %s ", $t->current_history);
470 printf("history_base: %d, ", $attribs->{history_base});
471 printf("history_length: %d, ", $attribs->{history_length});
472 # printf("max_input_history: %d ", $attribs->{max_input_history});
473 # printf("history_total_bytes: %d ", $t->history_total_bytes);
474 print "\n";
475 }
+8
-0
t/inputrc less more
0 # readline init file for t/readline.t
1 # `a' and `b' should be bind to about, and 'c' not.
2 "a": abort
3 $if ReadLineTest
4 "b": abort
5 $else
6 "c": abort
7 $endif⏎
+955
-0
t/readline.t less more
0 # -*- perl -*-
1 # readline.t - Test script for Term::ReadLine:GNU
2 #
3 # $Id: readline.t,v 1.44 2003-03-16 00:22:39-05 hiroo Exp hiroo $
4 #
5 # Copyright (c) 2002 Hiroo Hayashi. All rights reserved.
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the same terms as Perl itself.
9
10 # Before `make install' is performed this script should be runnable with
11 # `make test'. After `make install' it should work as `perl t/readline.t'
12
13 BEGIN {
14 print "1..104\n"; $n = 1;
15 $ENV{PERL_RL} = 'Gnu'; # force to use Term::ReadLine::Gnu
16 }
17 END {print "not ok 1\tfail to loading\n" unless $loaded;}
18
19 my $verbose = defined @ARGV && ($ARGV[0] eq 'verbose');
20
21 $^W = 1; # perl -w
22 use strict;
23 use vars qw($loaded $n);
24 eval "use ExtUtils::testlib;" or eval "use lib './blib';";
25 use Term::ReadLine;
26 use Term::ReadLine::Gnu qw(ISKMAP ISMACR ISFUNC RL_STATE_INITIALIZED);
27
28 $loaded = 1;
29 print "ok 1\tloading\n"; $n++;
30
31
32 # Perl-5.005 and later has Test.pm, but I define this here to support
33 # older version.
34 my $res;
35 my $ok = 1;
36 sub ok {
37 my $what = shift || '';
38
39 if ($res) {
40 print "ok $n\t$what\n";
41 } else {
42 print "not ok $n\t$what";
43 print @_ ? "\t@_\n" : "\n";
44 $ok = 0;
45 }
46 $n++;
47 }
48
49 ########################################################################
50 # test new method
51
52 $ENV{'INPUTRC'} = '/dev/null'; # stop reading ~/.inputrc
53
54 my $t = new Term::ReadLine 'ReadLineTest';
55 $res = defined $t; ok('new');
56
57 my $OUT;
58 if ($verbose) {
59 $OUT = $t->OUT;
60 } else {
61 open(NULL, '>/dev/null') or die "cannot open \`/dev/null\': $!\n";
62 $OUT = \*NULL;
63 $t->Attribs->{outstream} = \*NULL;
64 }
65
66 ########################################################################
67 # test ReadLine method
68
69 $res = $t->ReadLine eq 'Term::ReadLine::Gnu';
70 ok('ReadLine method',
71 "\tPackage name should be \`Term::ReadLine::Gnu\', but it is \`",
72 $t->ReadLine, "\'\n");
73
74 ########################################################################
75 # test Features method
76
77 my %features = %{ $t->Features };
78 $res = %features;
79 ok('Features method',"\tNo additional features present.\n");
80
81 ########################################################################
82 # test Attribs method
83
84 my $a = $t->Attribs;
85 $res = defined $a; ok('Attrib method');
86
87 ########################################################################
88 # 2.3 Readline Variables
89
90 my ($maj, $min) = $a->{library_version} =~ /(\d+)\.(\d+)/;
91 my $version = $a->{readline_version};
92 $res = ($version == 0x100 * $maj + $min); ok('readline_version');
93
94 # Version 2.0 is NOT supported.
95 $res = $version > 0x0200; ok('rl_version');
96
97 # check the values of initialized variables
98 $res = $a->{line_buffer} eq ''; ok;
99 $res = $a->{point} == 0; ok;
100 $res = $a->{end} == 0; ok;
101 $res = $a->{mark} == 0; ok;
102 $res = $a->{done} == 0; ok;
103 if ($version >= 0x0402) {
104 $res = $a->{num_chars_to_read} == 0; ok('num_chars_to_read');
105 } else {
106 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
107 $n++;
108 }
109 $res = $a->{pending_input} == 0; ok('pending_input');
110 if ($version >= 0x0402) {
111 $res = $a->{dispatching} == 0; ok('dispatching');
112 } else {
113 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
114 $n++;
115 }
116 $res = $a->{erase_empty_line} == 0; ok;
117 $res = ! defined($a->{prompt}); ok;
118 if ($version >= 0x0402) {
119 $res = $a->{already_prompted} == 0; ok('already_prompted');
120 $res = $a->{gnu_readline_p} == 1; ok('gnu_readline_p');
121 } else {
122 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
123 $n++;
124 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
125 $n++;
126 }
127 if ($version < 0x0402) {
128 $res = ! defined($a->{terminal_name}); ok;
129 } else {
130 $res = $a->{terminal_name} eq $ENV{TERM}; ok;
131 }
132 $res = $a->{readline_name} eq 'ReadLineTest'; ok('readline_name');
133
134 # rl_instream, rl_outstream, rl_last_func!!!,
135 # rl_startup_hook, rl_pre_input_hook, rl_event_hook,
136 # rl_getc_function, rl_redisplay_function
137 # rl_prep_term_function!!!, rl_deprep_term_function!!!
138
139 # not defined here
140 $res = ! defined($a->{executing_keymap}); ok('executing_keymap');
141 # anonymous keymap
142 $res = defined($a->{binding_keymap}); ok('binding_keymap');
143
144 if ($version >= 0x0402) {
145 $res = ! defined($a->{executing_macro}); ok('executing_macro');
146 $res = ($a->{readline_state} == RL_STATE_INITIALIZED);
147 ok('readline_state');
148 $res = $a->{explicit_arg} == 0; ok('explicit_arg');
149 $res = $a->{numeric_arg} == 1; ok('numeric_arg');
150 $res = $a->{editing_mode} == 1; ok('editing_mode');
151 } else {
152 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
153 $n++;
154 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
155 $n++;
156 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
157 $n++;
158 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
159 $n++;
160 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
161 $n++;
162 }
163
164 ########################################################################
165 # 2.4 Readline Convenience Functions
166
167 ########################################################################
168 # define some custom functions
169
170 sub reverse_line { # reverse a whole line
171 my($count, $key) = @_; # ignored in this sample function
172
173 $t->modifying(0, $a->{end}); # save undo information
174 $a->{line_buffer} = reverse $a->{line_buffer};
175 }
176
177 # From the GNU Readline Library Manual
178 # Invert the case of the COUNT following characters.
179 sub invert_case_line {
180 my($count, $key) = @_;
181
182 my $start = $a->{point};
183 return 0 if ($start >= $a->{end});
184
185 # Find the end of the range to modify.
186 my $end = $start + $count;
187
188 # Force it to be within range.
189 if ($end > $a->{end}) {
190 $end = $a->{end};
191 } elsif ($end < 0) {
192 $end = 0;
193 }
194
195 return 0 if $start == $end;
196
197 if ($start > $end) {
198 my $temp = $start;
199 $start = $end;
200 $end = $temp;
201 }
202
203 # Tell readline that we are modifying the line, so it will save
204 # undo information.
205 $t->modifying($start, $end);
206
207 # I'm happy with Perl :-)
208 substr($a->{line_buffer}, $start, $end-$start) =~ tr/a-zA-Z/A-Za-z/;
209
210 # Move point to on top of the last character changed.
211 $a->{point} = $count < 0 ? $start : $end - 1;
212 return 0;
213 }
214
215 ########################################################################
216 # 2.4.1 Naming a Function
217
218 my ($func, $type);
219
220 # test add_defun
221 $res = (! defined($t->named_function('reverse-line'))
222 && ! defined($t->named_function('invert-case-line'))
223 && defined($t->named_function('operate-and-get-next'))
224 && defined($t->named_function('display-readline-version'))
225 && defined($t->named_function('change-ornaments')));
226 ok('add_defun');
227
228 ($func, $type) = $t->function_of_keyseq("\ct");
229 $res = $type == ISFUNC && $t->get_function_name($func) eq 'transpose-chars';
230 ok;
231
232 $t->add_defun('reverse-line', \&reverse_line, ord "\ct");
233 $t->add_defun('invert-case-line', \&invert_case_line);
234
235 $res = (defined($t->named_function('reverse-line'))
236 && defined($t->named_function('invert-case-line'))
237 && defined($t->named_function('operate-and-get-next'))
238 && defined($t->named_function('display-readline-version'))
239 && defined($t->named_function('change-ornaments')));
240 ok;
241
242 ($func, $type) = $t->function_of_keyseq("\ct");
243 $res = $type == ISFUNC && $t->get_function_name($func) eq 'reverse-line';
244 ok;
245
246 ########################################################################
247 # 2.4.2 Selecting a Keymap
248
249 # test rl_make_bare_keymap, rl_copy_keymap, rl_make_keymap, rl_discard_keymap
250 my $baremap = $t->make_bare_keymap;
251 $t->bind_key(ord "a", 'abort', $baremap);
252 my $copymap = $t->copy_keymap($baremap);
253 $t->bind_key(ord "b", 'abort', $baremap);
254 my $normmap = $t->make_keymap;
255
256 $res = (($t->get_function_name(($t->function_of_keyseq('a', $baremap))[0])
257 eq 'abort')
258 && ($t->get_function_name(($t->function_of_keyseq('b', $baremap))[0])
259 eq 'abort')
260 && ($t->get_function_name(($t->function_of_keyseq('a', $copymap))[0])
261 eq 'abort')
262 && ! defined($t->function_of_keyseq('b', $copymap))
263 && ($t->get_function_name(($t->function_of_keyseq('a', $normmap))[0])
264 eq 'self-insert'));
265 ok('bind_key');
266
267 $t->discard_keymap($baremap);
268 $t->discard_keymap($copymap);
269 $t->discard_keymap($normmap);
270
271 # test rl_get_keymap, rl_set_keymap,
272 # rl_get_keymap_by_name, rl_get_keymap_name
273 $res = $t->get_keymap_name($t->get_keymap) eq 'emacs';
274 ok;
275
276 $t->set_keymap('vi');
277 $res = $t->get_keymap_name($t->get_keymap) eq 'vi';
278 ok;
279
280 # equivalent to $t->set_keymap('emacs');
281 $t->set_keymap($t->get_keymap_by_name('emacs'));
282 $res = $t->get_keymap_name($t->get_keymap) eq 'emacs';
283 ok;
284
285 ########################################################################
286 # 2.4.3 Binding Keys
287
288 #print $t->get_keymap_name($a->{executing_keymap}), "\n";
289 #print $t->get_keymap_name($a->{binding_keymap}), "\n";
290
291 # test rl_bind_key (rl_bind_key_in_map), rl_generic_bind, rl_parse_and_bind
292 # define subroutine to use again later
293 my ($helpmap, $mymacro);
294 sub bind_my_function {
295 $t->bind_key(ord "\ct", 'reverse-line');
296 $t->bind_key(ord "\cv", 'display-readline-version', 'emacs-ctlx');
297 $t->parse_and_bind('"\C-xv": display-readline-version');
298 $t->bind_key(ord "c", 'invert-case-line', 'emacs-meta');
299 if ($version >= 0x0402) {
300 # rl_set_key in introduced by GRL 4.2
301 $t->set_key("\eo", 'change-ornaments');
302 } else {
303 $t->bind_key(ord "o", 'change-ornaments', 'emacs-meta');
304 }
305 $t->bind_key(ord "^", 'history-expand-line', 'emacs-meta');
306
307 # make an original map
308 $helpmap = $t->make_bare_keymap();
309 $t->bind_key(ord "f", 'dump-functions', $helpmap);
310 $t->generic_bind(ISKMAP, "\e?", $helpmap);
311 $t->bind_key(ord "v", 'dump-variables', $helpmap);
312 # 'dump-macros' is documented but not defined by GNU Readline 2.1
313 $t->generic_bind(ISFUNC, "\e?m", 'dump-macros') if $version > 0x0201;
314
315 # bind a macro
316 $mymacro = "\ca[insert text from beginning of line]";
317 $t->generic_bind(ISMACR, "\e?i", $mymacro);
318 }
319
320 bind_my_function; # do bind
321
322 {
323 my ($fn, $ty);
324 # check keymap binding
325 ($fn, $ty) = $t->function_of_keyseq("\cX");
326 $res = $t->get_keymap_name($fn) eq 'emacs-ctlx' && $ty == ISKMAP;
327 ok('keymap binding');
328
329 # check macro binding
330 ($fn, $ty) = $t->function_of_keyseq("\e?i");
331 $res = $fn eq $mymacro && $ty == ISMACR;
332 ok('macro binding');
333 }
334
335 # check function binding
336 $res = (is_boundp("\cT", 'reverse-line')
337 && is_boundp("\cX\cV", 'display-readline-version')
338 && is_boundp("\cXv", 'display-readline-version')
339 && is_boundp("\ec", 'invert-case-line')
340 && is_boundp("\eo", 'change-ornaments')
341 && is_boundp("\e^", 'history-expand-line')
342 && is_boundp("\e?f", 'dump-functions')
343 && is_boundp("\e?v", 'dump-variables')
344 && ($version <= 0x0201 or is_boundp("\e?m", 'dump-macros')));
345 ok('function binding');
346
347 # test rl_read_init_file
348 $res = $t->read_init_file('t/inputrc') == 0;
349 ok('rl_read_init_file');
350
351 $res = (is_boundp("a", 'abort')
352 && is_boundp("b", 'abort')
353 && is_boundp("c", 'self-insert'));
354 ok;
355
356 # resume
357 $t->bind_key(ord "a", 'self-insert');
358 $t->bind_key(ord "b", 'self-insert');
359 $res = (is_boundp("a", 'self-insert')
360 && is_boundp("b", 'self-insert'));
361 ok;
362
363 # test rl_unbind_key (rl_unbind_key_in_map),
364 # rl_unbind_command_in_map, rl_unbind_function_in_map
365 $t->unbind_key(ord "\ct"); # reverse-line
366 $t->unbind_key(ord "f", $helpmap); # dump-function
367 $t->unbind_key(ord "v", 'emacs-ctlx'); # display-readline-version
368 if ($version > 0x0201) {
369 $t->unbind_command_in_map('display-readline-version', 'emacs-ctlx');
370 $t->unbind_function_in_map($t->named_function('dump-variables'), $helpmap);
371 } else {
372 $t->unbind_key(ord "\cV", 'emacs-ctlx');
373 $t->unbind_key(ord "v", $helpmap);
374 }
375
376 my @keyseqs = ($t->invoking_keyseqs('reverse-line'),
377 $t->invoking_keyseqs('dump-functions'),
378 $t->invoking_keyseqs('display-readline-version'),
379 $t->invoking_keyseqs('dump-variables'));
380 $res = scalar @keyseqs == 0; ok('unbind_key',"@keyseqs");
381
382 if ($version >= 0x0402) {
383 $t->add_funmap_entry('foo_bar', 'reverse-line');
384 # This does not work. We need `equal' in Lisp.
385 # $res = ($t->named_function('reverse-line')
386 # == $t->named_function('foo_bar'));
387 $res = defined $t->named_function('foo_bar');
388 ok('add_funmap_entry');
389 } else {
390 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
391 $n++;
392 }
393 ########################################################################
394 # 2.4.4 Associating Function Names and Bindings
395
396 bind_my_function; # do bind
397
398 # rl_named_function, rl_function_of_keyseq, and add_funmap_entry are
399 # tested above
400
401 # test rl_invoking_keyseqs
402 @keyseqs = $t->invoking_keyseqs('abort', 'emacs-ctlx');
403 $res = "\\C-g" eq "@keyseqs";
404 ok('invoking_keyseqs');
405
406 # Test rl_function_dumper!!!, rl_list_funmap_names!!!, rl_funmap_names!!!
407 ########################################################################
408 # 2.4.5 Allowing Undoing
409 # rl_begin_undo_group!!!, rl_end_undo_group!!!, rl_add_undo!!!,
410 # rl_free_undo_list!!!, rl_do_undo!!!, rl_modifying
411 ########################################################################
412 # 2.4.6 Redisplay
413 # rl_redisplay!!!, rl_forced_update_display, rl_on_new_line!!!,
414 # rl_on_new_line_with_prompt!!!, rl_reset_line_state!!!, rl_crlf!!!,
415 # rl_show_char!!!,
416 # rl_message, rl_clear_message, rl_save_prompt, rl_restore_prompt:
417 # see Gnu/XS.pm:change_ornaments()
418 # rl_expand_prompt!!!, rl_set_prompt!!!
419 ########################################################################
420 # 2.4.7 Modifying Text
421 # rl_insert_text!!!, rl_delete_text!!!, rl_copy_text!!!, rl_kill_text!!!,
422 # rl_push_macro_input!!!
423 ########################################################################
424 # 2.4.8 Character Input
425 # rl_read_key!!!, rl_getc, rl_stuff_char!!!, rl_execute_next!!!,
426 # rl_clear_pending_input!!!
427 ########################################################################
428 # 2.4.9 Terminal Management
429 # rl_prep_terminal!!!, rl_deprep_terminal!!!,
430 # rl_tty_set_default_bindings!!!, rl_reset_terminal!!!
431 ########################################################################
432 # 2.4.10 Utility Functions
433 # rl_extend_line_buffer!!!, rl_initialize, rl_ding!!!, rl_alphabetic!!!,
434 # rl_display_match_list
435 ########################################################################
436 # 2.4.11 Miscellaneous Functions
437 # rl_macro_bind!!!, rl_macro_dumpter!!!,
438 # rl_variable_bind!!!, rl_variable_dumper!!!
439 # rl_set_paren_blink_timeout!!!
440 # rl_get_termcap!!!
441 ########################################################################
442 # 2.4.12 Alternate Interface
443 # tested in callbac,.t
444 # rl_callback_handler_install, rl_callback_read_char,
445 # rl_callback_handler_remove,
446 ########################################################################
447 # 2.5 Readline Signal Handling
448 $res = $a->{catch_signals} == 1; ok('catch_signals');
449 $res = $a->{catch_sigwinch} == 1; ok('catch_sigwinch');
450
451 # rl_cleanup_after_signal!!!, rl_free_line_state!!!,
452 # rl_reset_after_signal!!!, rl_resize_terminal!!!,
453 # rl_set_screen_size, rl_get_screen_size
454 if ($version >= 0x0402) {
455 my ($rowsav, $colsav) = $t->get_screen_size;
456 $t->set_screen_size(60, 132);
457 my ($row, $col) = $t->get_screen_size;
458 # col=131 on a terminal which does not support auto-wrap function
459 $res = ($row == 60 && ($col == 132 || $col == 131));
460 ok('set/get_screen_size');
461 $t->set_screen_size($rowsav, $colsav);
462 } else {
463 print "ok $n # skipped because GNU Readline Library is older than 4.2.\n";
464 $n++;
465 }
466 # rl_set_signals!!!, rl_clear_signals!!!
467 ########################################################################
468 # 2.6 Custom Completers
469 # 2.6.1 How Completing Works
470 # 2.6.2 Completion Functions
471 # rl_complete_internal!!!, rl_possible_completions!!!,
472 # rl_insert_completions!!!, rl_completion_matches,
473 # rl_filename_completion_function, rl_username_completion_function
474 # 2.6.3 Completion Variables
475 $res = ! defined $a->{completion_entry_function}; ok;
476 $res = ! defined $a->{attempted_completion_function}; ok;
477 $res = ! defined $a->{filename_quoting_function}; ok;
478 $res = ! defined $a->{filename_dequoting_function}; ok;
479 $res = ! defined $a->{char_is_quoted_p}; ok;
480 $res = $a->{completion_query_items} == 100; ok;
481 $res = ($a->{basic_word_break_characters}
482 eq " \t\n\"\\'`\@\$><=;|&{("); ok;
483 $res = $a->{basic_quote_characters} eq "\"'"; ok;
484 $res = ($a->{completer_word_break_characters}
485 eq " \t\n\"\\'`\@\$><=;|&{("); ok;
486 $res = ! defined $a->{completer_quote_characters}; ok;
487 $res = ! defined $a->{filename_quote_characters}; ok;
488 $res = ! defined $a->{special_prefixes}; ok;
489 $res = $a->{completion_append_character} eq " "; ok;
490 $res = $a->{ignore_completion_duplicates} == 1; ok;
491 $res = $a->{filename_completion_desired} == 0; ok;
492 $res = $a->{filename_quoting_desired} == 1; ok;
493 $res = $a->{attempted_completion_over} == 0; ok;
494 $res = $a->{completion_type} == 0; ok;
495 $res = $a->{inhibit_completion} == 0; ok;
496 $res = ! defined $a->{ignore_some_completions_function};ok;
497 $res = ! defined $a->{directory_completions_hook}; ok;
498 $res = ! defined $a->{completions_display_matches_hook};ok;
499
500
501 ########################################################################
502
503 $t->parse_and_bind('set bell-style none'); # make readline quiet
504
505 my ($INSTR, $line);
506 # simulate key input by using a variable 'rl_getc_function'
507 $a->{getc_function} = sub {
508 unless (length $INSTR) {
509 print $OUT "Error: getc_function: insufficient string, \`\$INSTR\'.";
510 undef $a->{getc_function};
511 return 0;
512 }
513 my $c = substr $INSTR, 0, 1; # the first char of $INSTR
514 $INSTR = substr $INSTR, 1; # rest of $INSTR
515 return ord $c;
516 };
517
518 # check some key binding used by following test
519 sub is_boundp {
520 my ($seq, $fname) = @_;
521 my ($fn, $type) = $t->function_of_keyseq($seq);
522 if ($fn) {
523 return ($t->get_function_name($fn) eq $fname
524 && $type == ISFUNC);
525 } else {
526 warn ("No function is bound for sequence \`", toprint($seq),
527 "\'. \`$fname\' is expected,");
528 return 0;
529 }
530 }
531
532 $res = (is_boundp("\cM", 'accept-line')
533 && is_boundp("\cF", 'forward-char')
534 && is_boundp("\cB", 'backward-char')
535 && is_boundp("\ef", 'forward-word')
536 && is_boundp("\eb", 'backward-word')
537 && is_boundp("\cE", 'end-of-line')
538 && is_boundp("\cA", 'beginning-of-line')
539 && is_boundp("\cH", 'backward-delete-char')
540 && is_boundp("\cD", 'delete-char')
541 && is_boundp("\cI", 'complete'));
542 ok('default key binding',
543 "Default key binding is changed? Some of following test will fail.");
544
545 $INSTR = "abcdefgh\cM";
546 $line = $t->readline("self insert> ");
547 $res = $line eq 'abcdefgh'; ok('self insert', $line);
548
549 $INSTR = "\cAe\cFf\cBg\cEh\cH ij kl\eb\ebm\cDn\cM";
550 $line = $t->readline("cursor move> ", 'abcd'); # default string
551 $res = $line eq 'eagfbcd mnj kl'; ok('cursor move', $line);
552
553 # test reverse_line, display_readline_version, invert_case_line
554 $INSTR = "\cXvabcdefgh XYZ\e6\cB\e4\ec\cT\cM";
555 $line = $t->readline("custom commands> ");
556 $res = $line eq 'ZYx HGfedcba'; ok('custom commands', $line);
557
558 # test undo of reverse_line
559 $INSTR = "abcdefgh\cTi\c_\c_\cM";
560 $line = $t->readline("test undo> ");
561 $res = $line eq 'abcdefgh'; ok('undo', $line);
562
563 # test macro, change_ornaments
564 $INSTR = "1234\e?i\eoB\cM\cM";
565 $line = $t->readline("keyboard macro> ");
566 $res = $line eq "[insert text from beginning of line]1234"; ok('macro', $line);
567 $INSTR = "\cM";
568 $line = $t->readline("bold face prompt> ");
569 $res = $line eq ''; ok('ornaments', $line);
570
571 # test operate_and_get_next
572 $INSTR = "one\cMtwo\cMthree\cM\cP\cP\cP\cO\cO\cO\cM";
573 $line = $t->readline("> "); # one
574 $line = $t->readline("> "); # two
575 $line = $t->readline("> "); # three
576 $line = $t->readline("> ");
577 $res = $line eq 'one'; ok('operate_and_get_next 1', $line);
578 $line = $t->readline("> ");
579 $res = $line eq 'two'; ok('operate_and_get_next 2', $line);
580 $line = $t->readline("> ");
581 $res = $line eq 'three'; ok('operate_and_get_next 3', $line);
582 $line = $t->readline("> ");
583 $res = $line eq 'one'; ok('operate_and_get_next 4', $line);
584
585 ########################################################################
586 # test history expansion
587
588 $t->ornaments(0); # ornaments off
589
590 #print $OUT "\n# history expansion test\n# quit by EOF (\\C-d)\n";
591 $a->{do_expand} = 1;
592 $t->MinLine(4);
593
594 sub prompt {
595 # equivalent with "$nline = $t->where_history + 1"
596 my $nline = $a->{history_base} + $a->{history_length};
597 "$nline> ";
598 }
599
600 $INSTR = "!1\cM";
601 $line = $t->readline(prompt);
602 $res = $line eq 'abcdefgh'; ok('history 1', $line);
603
604 $INSTR = "123\cM"; # too short
605 $line = $t->readline(prompt);
606 $INSTR = "!!\cM";
607 $line = $t->readline(prompt);
608 $res = $line eq 'abcdefgh'; ok('history 2', $line);
609
610 $INSTR = "1234\cM";
611 $line = $t->readline(prompt);
612 $INSTR = "!!\cM";
613 $line = $t->readline(prompt);
614 $res = $line eq '1234'; ok('history 3', $line);
615
616 ########################################################################
617 # test custom completion function
618
619 $t->parse_and_bind('set bell-style none'); # make readline quiet
620
621 $INSTR = "t/comp\cI\e*\cM";
622 $line = $t->readline("insert completion>");
623 # "a_b" < "README" on some kind of locale since strcoll() is used in
624 # the GNU Readline Library.
625 # Not all perl support setlocale. My perl supports locale and I tried
626 # use POSIX qw(locale_h); setlocale(LC_COLLATE, 'C');
627 # But it seems that it does not affect strcoll() linked to GNU
628 # Readline Library.
629 $res = $line eq 't/comptest/0123 t/comptest/012345 t/comptest/023456 t/comptest/README t/comptest/a_b '
630 || $line eq 't/comptest/0123 t/comptest/012345 t/comptest/023456 t/comptest/a_b t/comptest/README ';
631 ok('insert completion', $line);
632
633 $INSTR = "t/comp\cIR\cI\cM";
634 $line = $t->readline("filename completion (default)>");
635 $res = $line eq 't/comptest/README '; ok('default completion', $line);
636
637 $a->{completion_entry_function} = $a->{'username_completion_function'};
638 my $user = getlogin || 'root';
639 $INSTR = "${user}\cI\cM";
640 $line = $t->readline("username completion>");
641 if ($line eq "${user} ") {
642 print "ok $n\tusername completion\n"; $n++;
643 } elsif ($line eq ${user}) {
644 print "ok $n\t# skipped. It seems that there is no user whose name is '${user}' or there is a user whose name starts with '${user}'\n"; $n++;
645 } else {
646 print "not ok $n\tusername completion\n"; $n++;
647 $ok = 0;
648 }
649
650 $a->{completion_word} = [qw(a list of words for completion and another word)];
651 $a->{completion_entry_function} = $a->{'list_completion_function'};
652 print $OUT "given list is: a list of words for completion and another word\n";
653 $INSTR = "a\cI\cIn\cI\cIo\cI\cM";
654 $line = $t->readline("list completion>");
655 $res = $line eq 'another '; ok('list completion', $line);
656
657
658 $a->{completion_entry_function} = $a->{'filename_completion_function'};
659 $INSTR = "t/comp\cI\cI\cI0\cI\cI1\cI\cI\cM";
660 $line = $t->readline("filename completion>");
661 $res = $line eq 't/comptest/0123'; ok('filename completion', $line);
662 undef $a->{completion_entry_function};
663
664 # attempted_completion_function
665
666 $a->{attempted_completion_function} = sub { undef; };
667 $a->{completion_entry_function} = sub {};
668 $INSTR = "t/comp\cI\cM";
669 $line = $t->readline("null completion 1>");
670 $res = $line eq 't/comp'; ok('null completion 1', $line);
671
672 $a->{attempted_completion_function} = sub { (undef, undef); };
673 undef $a->{completion_entry_function};
674 $INSTR = "t/comp\cI\cM";
675 $line = $t->readline("null completion 2>");
676 $res = $line eq 't/comptest/'; ok('null completion 2', $line);
677
678 sub sample_completion {
679 my ($text, $line, $start, $end) = @_;
680 # If first word then username completion, else filename completion
681 if (substr($line, 0, $start) =~ /^\s*$/) {
682 return $t->completion_matches($text, $a->{'list_completion_function'});
683 } else {
684 return ();
685 }
686 }
687
688 $a->{attempted_completion_function} = \&sample_completion;
689 print $OUT "given list is: a list of words for completion and another word\n";
690 $INSTR = "li\cIt/comp\cI\cI\cI0\cI\cI2\cI\cM";
691 $line = $t->readline("list & filename completion>");
692 $res = $line eq 'list t/comptest/023456 '; ok('list & file completion', $line);
693 undef $a->{attempted_completion_function};
694
695 # ignore_some_completions_function
696 $a->{ignore_some_completions_function} = sub {
697 return (grep m|/$| || ! m|^(.*/)?[0-9]*$|, @_);
698 };
699 $INSTR = "t/co\cIRE\cI\cM";
700 $line = $t->readline("ignore_some_completion>");
701 $res = $line eq 't/comptest/README '; ok('ingore_some_completion', $line);
702 undef $a->{ignore_some_completions_function};
703
704 # char_is_quoted, filename_quoting_function, filename_dequoting_function
705
706 sub char_is_quoted ($$) { # borrowed from bash-2.03:subst.c
707 my ($string, $eindex) = @_;
708 my ($i, $pass_next);
709
710 for ($i = $pass_next = 0; $i <= $eindex; $i++) {
711 my $c = substr($string, $i, 1);
712 if ($pass_next) {
713 $pass_next = 0;
714 return 1 if ($i >= $eindex); # XXX was if (i >= eindex - 1)
715 } elsif ($c eq '\'') {
716 $i = index($string, '\'', ++$i);
717 return 1 if ($i == -1 || $i >= $eindex);
718 # } elsif ($c eq '"') { # ignore double quote
719 } elsif ($c eq '\\') {
720 $pass_next = 1;
721 }
722 }
723 return 0;
724 }
725 $a->{char_is_quoted_p} = \&char_is_quoted;
726 $a->{filename_quoting_function} = sub {
727 my ($text, $match_type, $quote_pointer) = @_;
728 my $qc = $a->{filename_quote_characters};
729 return $text if $quote_pointer;
730 $text =~ s/[\Q${qc}\E]/\\$&/;
731 return $text;
732 };
733 $a->{filename_dequoting_function} = sub {
734 my ($text, $quote_char) = @_;
735 $quote_char = chr $quote_char;
736 $text =~ s/\\//g;
737 return $text;
738 };
739
740 $a->{completer_quote_characters} = '\'';
741 $a->{filename_quote_characters} = ' _\'\\';
742
743 $INSTR = "t/comp\cIa\cI 't/comp\cIa\cI\cM";
744 $line = $t->readline("filename_quoting_function>");
745 $res = $line eq 't/comptest/a\\_b \'t/comptest/a_b\' ';
746 ok('filename_quoting_function', $line);
747
748 $INSTR = "\'t/comp\cIa\\_\cI\cM";
749 $line = $t->readline("filename_dequoting_function>");
750 $res = $line eq '\'t/comptest/a_b\' ';
751 ok('filename_dequoting_function', $line);
752
753 undef $a->{char_is_quoted_p};
754 undef $a->{filename_quoting_function};
755 undef $a->{filename_dequoting_function};
756
757 # directory_completion_hook
758 $a->{directory_completion_hook} = sub {
759 if ($_[0] eq 'comp/') { # simple alias function
760 $_[0] = 't/comptest/';
761 return 1;
762 } else {
763 return 0;
764 }
765 };
766
767 $INSTR = "comp/\cI\cM";
768 $line = $t->readline("directory_completion_hook>");
769 $res = $line eq 't/comptest/';
770 ok('directory_completion_hook', $line);
771 undef $a->{directory_completion_hook};
772
773 # filename_list
774 my @m = $t->filename_list('t/comptest/01');
775 $res = $#m == 1;
776 ok('filename_list', $#m);
777
778 $t->parse_and_bind('set bell-style audible'); # resume to default style
779
780 ########################################################################
781 # test rl_startup_hook, rl_pre_input_hook
782
783 $a->{startup_hook} = sub { $a->{point} = 10; };
784 $INSTR = "insert\cM";
785 $line = $t->readline("rl_startup_hook test>", "cursor is, <- here");
786 $res = $line eq 'cursor is,insert <- here'; ok('startup_hook', $line);
787 $a->{startup_hook} = undef;
788
789 $a->{pre_input_hook} = sub { $a->{point} = 10; };
790 $INSTR = "insert\cM";
791 $line = $t->readline("rl_pre_input_hook test>", "cursor is, <- here");
792 if ($version >= 0x0400) {
793 $res = $line eq 'cursor is,insert <- here'; ok('pre_input_hook', $line);
794 } else {
795 print "ok $n # skipped because GNU Readline Library is older than 4.0.\n";
796 $n++;
797 }
798 $a->{pre_input_hook} = undef;
799
800 #########################################################################
801 # test redisplay_function
802 $a->{redisplay_function} = $a->{shadow_redisplay};
803 $INSTR = "\cX\cVThis is a password.\cM";
804 $line = $t->readline("password> ");
805 $res = $line eq 'This is a password.'; ok('redisplay_function', $line);
806 undef $a->{redisplay_function};
807
808 print "ok $n\n"; $n++;
809
810 #########################################################################
811 # test rl_display_match_list
812
813 if ($version >= 0x0400) {
814 my @match_list = @{$a->{completion_word}};
815 $t->display_match_list(\@match_list);
816 $t->parse_and_bind('set print-completions-horizontally on');
817 $t->display_match_list(\@match_list);
818 $t->parse_and_bind('set print-completions-horizontally off');
819 print "ok $n\n"; $n++;
820 } else {
821 print "ok $n # skipped because GNU Readline Library is older than 4.0.\n";
822 $n++;
823 }
824
825 #########################################################################
826 # test rl_completion_display_matches_hook
827
828 if ($version >= 0x0400) {
829 # See 'eg/perlsh' for better example
830 $a->{completion_display_matches_hook} = sub {
831 my($matches, $num_matches, $max_length) = @_;
832 map { $_ = uc $_; }(@{$matches});
833 $t->display_match_list($matches);
834 $t->forced_update_display;
835 };
836 $t->parse_and_bind('set bell-style none'); # make readline quiet
837 $INSTR = "Gnu.\cI\cI\cM";
838 $t->readline("completion_display_matches_hook>");
839 undef $a->{completion_display_matches_hook};
840 print "ok $n\n"; $n++;
841 $t->parse_and_bind('set bell-style audible'); # resume to default style
842 } else {
843 print "ok $n # skipped because GNU Readline Library is older than 4.0.\n";
844 $n++;
845 }
846
847 ########################################################################
848 # test ornaments
849
850 $INSTR = "\cM\cM\cM\cM\cM\cM\cM";
851 print $OUT "# ornaments test\n";
852 print $OUT "# Note: Some function may not work on your terminal.\n";
853 # Kterm seems to have a bug with 'ue' (End underlining) does not work\n";
854 $t->ornaments(1); # equivalent to 'us,ue,md,me'
855 print $OUT "\n" unless defined $t->readline("default ornaments (underline)>");
856 # cf. man termcap(5)
857 $t->ornaments('so,me,,');
858 print $OUT "\n" unless defined $t->readline("standout>");
859 $t->ornaments('us,me,,');
860 print $OUT "\n" unless defined $t->readline("underlining>");
861 $t->ornaments('mb,me,,');
862 print $OUT "\n" unless defined $t->readline("blinking>");
863 $t->ornaments('md,me,,');
864 print $OUT "\n" unless defined $t->readline("bold>");
865 $t->ornaments('mr,me,,');
866 print $OUT "\n" unless defined $t->readline("reverse>");
867 $t->ornaments('vb,,,');
868 print $OUT "\n" unless defined $t->readline("visible bell>");
869 $t->ornaments(0);
870 print $OUT "# end of ornaments test\n";
871
872 print "ok $n\n"; $n++;
873
874 ########################################################################
875 # end of non-interactive test
876 unless ($verbose) {
877 # $^X : `perl' for dynamically linked perl, `./perl' for
878 # statically linked perl.
879 print STDERR "ok\tTry \`$^X -Mblib t/readline.t verbose\', if you will.\n"
880 if $ok;
881 exit 0;
882 }
883 undef $a->{getc_function};
884
885 ########################################################################
886 # interactive test
887
888 ########################################################################
889 # test redisplay_function
890
891 $a->{redisplay_function} = $a->{shadow_redisplay};
892 $line = $t->readline("password> ");
893 print "<$line>\n";
894 undef $a->{redisplay_function};
895
896 ########################################################################
897 # test rl_getc_function and rl_getc()
898
899 sub uppercase {
900 # my $FILE = $a->{instream};
901 # return ord uc chr $t->getc($FILE);
902 return ord uc chr $t->getc($a->{instream});
903 }
904
905 $a->{getc_function} = \&uppercase;
906 print $OUT "\n" unless defined $t->readline("convert to uppercase>");
907 $a->{getc_function} = undef;
908
909 ########################################################################
910 # test event_hook
911 $a->{getc_function} = undef;
912
913 my $timer = 20; # 20 x 0.1 = 2.0 sec timer
914 $a->{event_hook} = sub {
915 if ($timer-- < 0) {
916 $a->{done} = 1;
917 undef $a->{event_hook};
918 }
919 };
920 $line = $t->readline("input in 2 seconds> ");
921 undef $a->{event_hook};
922 print "<$line>\n";
923
924 ########################################################################
925 # convert control charactors to printable charactors (ex. "\cx" -> '\C-x')
926 sub toprint {
927 join('',
928 map{$_ eq "\e" ? '\M-': ord($_)<32 ? '\C-'.lc(chr(ord($_)+64)) : $_}
929 (split('', $_[0])));
930 }
931
932 my %TYPE = (0 => 'Function', 1 => 'Keymap', 2 => 'Macro');
933
934 print $OUT "\n# Try the following commands.\n";
935 foreach ("\co", "\ct", "\cx",
936 "\cx\cv", "\cxv", "\ec", "\e^",
937 "\e?f", "\e?v", "\e?m", "\e?i", "\eo") {
938 my ($p, $type) = $t->function_of_keyseq($_);
939 printf $OUT "%-9s: ", toprint($_);
940 (print "\n", next) unless defined $type;
941 printf $OUT "%-8s : ", $TYPE{$type};
942 if ($type == ISFUNC) { print $OUT ($t->get_function_name($p)); }
943 elsif ($type == ISKMAP) { print $OUT ($t->get_keymap_name($p)); }
944 elsif ($type == ISMACR) { print $OUT (toprint($p)); }
945 else { print $OUT "Error: Illegal type value"; }
946 print $OUT "\n";
947 }
948
949 print $OUT "\n# history expansion test\n# quit by EOF (\\C-d)\n";
950 $a->{do_expand} = 1;
951 while (defined($line = $t->readline(prompt))) {
952 print $OUT "<<$line>>\n";
953 }
954 print $OUT "\n";
+38
-0
typemap less more
0 # typemap for Term::ReadLine::Gnu
1 #
2 # $Id: typemap,v 1.8 2004-10-17 11:44:57-05 hiroo Exp $
3
4 const char * T_PV
5 CONST char * T_PV
6 Keymap T_PTROBJ
7 Function * T_PTROBJ
8 rl_command_func_t * T_PTROBJ
9 FILE * T_STDIO
10 HIST_ENTRY * T_HIST_ENTRY
11 t_xstr T_XSTR
12
13 ########################################################################
14 INPUT
15 T_STDIO
16 $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
17
18 ########################################################################
19 OUTPUT
20 T_STDIO
21 {
22 GV *gv = newGVgen("$Package");
23 PerlIO *fp = PerlIO_importFILE($var,0);
24 if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
25 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
26 else
27 $arg = &PL_sv_undef;
28 }
29 T_XSTR
30 if ($var) {
31 sv_setpv($arg, $var);
32 xfree($var);
33 }
34 T_HIST_ENTRY
35 if ($var && $var->line) {
36 sv_setpv($arg, $var->line);
37 }