File Coverage

blib/lib/Term/ReadLine/Perl5/OO.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             package Term::ReadLine::Perl5::OO;
2 2     2   18353 use 5.008005;
  2         6  
  2         74  
3 2     2   9 use strict; use warnings;
  2     2   3  
  2         58  
  2         7  
  2         2  
  2         64  
4 2     2   933 use POSIX qw(termios_h);
  2         9991  
  2         10  
5 2     2   3477 use Storable;
  2         5318  
  2         139  
6 2     2   897 use Text::VisualWidth::PP 0.03 qw(vwidth);
  2         37969  
  2         201  
7 2     2   1194 use Unicode::EastAsianWidth::Detect qw(is_cjk_lang);
  2         1537  
  2         140  
8 2     2   1433 use Term::ReadKey qw(GetTerminalSize ReadLine ReadKey ReadMode);
  0            
  0            
9             use IO::Handle;
10             use English;
11              
12             eval "use rlib '.' "; # rlib is now optional
13             use Term::ReadLine::Perl5::OO::History;
14             use Term::ReadLine::Perl5::OO::Keymap;
15             use Term::ReadLine::Perl5::OO::State;
16             use Term::ReadLine::Perl5::Common;
17             use Term::ReadLine::Perl5::readline;
18             use Term::ReadLine::Perl5::TermCap;
19              
20             our $VERSION = "0.40";
21              
22             use constant HISTORY_NEXT => +1;
23             use constant HISTORY_PREV => -1;
24              
25             my $IS_WIN32 = $^O eq 'MSWin32';
26             require Win32::Console::ANSI if $IS_WIN32;
27              
28             use Class::Accessor::Lite 0.05 (
29             rw => [qw(completion_callback rl_MaxHistorySize)],
30             );
31              
32             use constant {
33             CTRL_B => 2,
34             CTRL_C => 3,
35             CTRL_F => 6,
36             CTRL_H => 8,
37             CTRL_Z => 26,
38             BACKSPACE => 127,
39             ENTER => 13,
40             TAB => 9,
41             ESC => 27,
42             };
43              
44             no warnings 'once';
45             *add_history = \&Term::ReadLine::Perl5::OO::History::add_history;
46             *read_history = \&Term::ReadLine::Perl5::OO::History::read_history;
47             *write_history = \&Term::ReadLine::Perl5::OO::History::write_history;
48             use warnings 'once';
49              
50             my %attribs = (
51             stiflehistory => 1,
52             getHistory => 1,
53             addHistory => 1,
54             attribs => 1,
55             appname => 1,
56             autohistory => 1,
57             readHistory => 1,
58             setHistory => 1
59             );
60              
61             my %features = (
62             appname => 1, # "new" is recognized
63             minline => 1, # we have a working MinLine()
64             autohistory => 1, # lines are put into history automatically,
65             # subject to MinLine()
66             getHistory => 1, # we have a working getHistory()
67             setHistory => 1, # we have a working setHistory()
68             addHistory => 1, # we have a working add_history(), addhistory(),
69             # or addHistory()
70             attribs => 1,
71             stiflehistory => 1, # we have stifle_history()
72             );
73              
74              
75             sub Attribs { \%attribs; }
76             sub Features { \%features; }
77              
78             our @EmacsKeymap = ();
79              
80             =head3 new
81              
82             B([I<%options>])
83              
84             returns the handle for subsequent calls to following functions.
85             Argument is the name of the application.
86              
87             =cut
88             sub new {
89             my $class = shift;
90             my %args = @_==1? %{$_[0]} : @_;
91             my $self = bless {
92              
93             char => undef, # last character
94             current_keymap => Term::ReadLine::Perl5::OO::Keymap::EmacsKeymap(),
95             toplevel_keymap => Term::ReadLine::Perl5::OO::Keymap::EmacsKeymap(),
96             debug => !!$ENV{CAROLINE_DEBUG},
97             history_base => 0,
98             history_stifled => 0,
99             minlength => 1,
100             multi_line => 1,
101             rl_HistoryIndex => 0, # Is set on use
102             rl_MaxHistorySize => 100,
103             rl_history_length => 0, # is set on use
104             rl_max_input_history => 0,
105             state => undef, # line buffer and its state
106             rl_History => [],
107             rl_term_set => \@Term::ReadLine::TermCap::rl_term_set,
108             %args
109             }, $class;
110             return $self;
111             }
112              
113             sub debug {
114             my ($self, $stuff) = @_;
115             return unless $self->{debug};
116              
117             # require JSON::PP;
118             open my $fh, '>>:utf8', 'readline-oo.debug.log';
119             print $fh $stuff;
120             # print $fh JSON::PP->new->allow_nonref(1)->encode($stuff) . "\n";
121             close $fh;
122             }
123              
124             sub is_supported($) {
125             my $self = shift;
126             return 1 if $IS_WIN32;
127             my $term = $ENV{'TERM'};
128             return 0 unless defined $term;
129             return 0 if $term eq 'dumb';
130             return 0 if $term eq 'cons25';
131             return 1;
132             }
133              
134             #### FIXME redo this history stuff:
135             sub history($) { shift->{rl_History} }
136              
137             sub history_len($) {
138             shift->{rl_history_length};
139             }
140              
141             sub refresh_line {
142             my ($self, $state) = @_;
143             if ($self->{multi_line}) {
144             $self->refresh_multi_line($state);
145             } else {
146             $self->refresh_single_line($state);
147             }
148             }
149              
150             sub refresh_multi_line {
151             my ($self, $state) = @_;
152              
153             my $plen = vwidth($state->prompt);
154             $self->debug($state->buf . "\n");
155              
156             # rows used by current buf
157             my $rows = int(($plen + vwidth($state->buf) + $state->cols -1) / $state->cols);
158             if (defined $state->query) {
159             $rows++;
160             }
161              
162             # cursor relative row
163             my $rpos = int(($plen + $state->oldpos + $state->cols) / $state->cols);
164              
165             my $old_rows = $state->maxrows;
166              
167             # update maxrows if needed.
168             if ($rows > $state->maxrows) {
169             $state->maxrows($rows);
170             }
171              
172             $self->debug(sprintf "[%d %d %d] p: %d, rows: %d, rpos: %d, max: %d, oldmax: %d",
173             $state->len, $state->pos, $state->oldpos, $plen, $rows, $rpos, $state->maxrows, $old_rows);
174              
175             # First step: clear all the lines used before. To do start by going to the last row.
176             if ($old_rows - $rpos > 0) {
177             $self->debug(sprintf ", go down %d", $old_rows-$rpos);
178             printf STDOUT "\x1b[%dB", $old_rows-$rpos;
179             }
180              
181             # Now for every row clear it, go up.
182             my $j;
183             for ($j=0; $j < ($old_rows-1); ++$j) {
184             $self->debug(sprintf ", clear+up %d %d", $old_rows-1, $j);
185             print("\x1b[0G\x1b[0K\x1b[1A");
186             }
187              
188             # Clean the top line
189             $self->debug(", clear");
190             print("\x1b[0G\x1b[0K");
191              
192             # Write the prompt and the current buffer content
193             print $state->prompt;
194             print $state->buf;
195             if (defined $state->query) {
196             print "\015\nSearch: " . $state->query;
197             }
198              
199             # If we are at the very end of the screen with our prompt, we need to
200             # emit a newline and move the prompt to the first column
201             if ($state->pos && $state->pos == $state->len && ($state->pos + $plen) % $state->cols == 0) {
202             $self->debug("");
203             print "\n";
204             print "\x1b[0G";
205             $rows++;
206             if ($rows > $state->maxrows) {
207             $state->maxrows(int $rows);
208             }
209             }
210              
211             # Move cursor to right position
212             my $rpos2 = int(($plen + $state->vpos + $state->cols) / $state->cols); # current cursor relative row
213             $self->debug(sprintf ", rpos2 %d", $rpos2);
214             # Go up till we reach the expected position
215             if ($rows - $rpos2 > 0) {
216             # cursor up
217             printf "\x1b[%dA", $rows-$rpos2;
218             }
219              
220             # Set column
221             my $col;
222             {
223             $col = 1;
224             my $buf = $state->prompt . substr($state->buf, 0, $state->pos);
225             for (split //, $buf) {
226             $col += vwidth($_);
227             if ($col > $state->cols) {
228             $col -= $state->cols;
229             }
230             }
231             }
232             $self->debug(sprintf ", set col %d", $col);
233             printf "\x1b[%dG", $col;
234              
235             $state->oldpos($state->pos);
236              
237             $self->debug("\n");
238             }
239              
240              
241             # Show the line, default inverted.
242             sub redisplay_inverted($$) {
243             my ($self, $line) = @_;
244              
245             # FIXME: fixup from readline::redisplay_high
246             # get_ornaments_selected();
247             # @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
248              
249             # Show the line, default inverted.
250             print STDOUT $line;
251              
252             # FIXME: fixup from readline::redisplay_high
253             # @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
254             }
255              
256             sub refresh_single_line($$) {
257             my ($self, $state) = @_;
258              
259             my $buf = $state->buf;
260             my $len = $state->len;
261             my $pos = $state->pos;
262             while ((vwidth($state->prompt)+$pos) >= $state->cols) {
263             substr($buf, 0, 1) = '';
264             $len--;
265             $pos--;
266             }
267             while (vwidth($state->prompt) + vwidth($buf) > $state->cols) {
268             $len--;
269             }
270              
271             print STDOUT "\x1b[0G"; # cursor to left edge
272             $self->redisplay_high($self->{prompt});
273             print STDOUT $buf;
274             print STDOUT "\x1b[0K"; # erase to right
275              
276             # Move cursor to original position
277             printf "\x1b[0G\x1b[%dC", (
278             length($state->{prompt})
279             + vwidth(substr($buf, 0, $pos))
280             );
281             }
282              
283             sub edit_insert {
284             my ($self, $state, $c) = @_;
285             if (length($state->buf) == $state->pos) {
286             $state->{buf} .= $c;
287             } else {
288             substr($state->{buf}, $state->{pos}, 0) = $c;
289             }
290             $state->{pos}++;
291             $self->refresh_line($state);
292             }
293              
294             sub edit_delete_prev_word {
295             my ($self, $state) = @_;
296              
297             my $old_pos = $state->pos;
298             while ($state->pos > 0 && substr($state->buf, $state->pos-1, 1) eq ' ') {
299             $state->{pos}--;
300             }
301             while ($state->pos > 0 && substr($state->buf, $state->pos-1, 1) ne ' ') {
302             $state->{pos}--;
303             }
304             my $diff = $old_pos - $state->pos;
305             substr($state->{buf}, $state->pos, $diff) = '';
306             $self->refresh_line($state);
307             }
308              
309             sub edit_history($$$) {
310             my ($self, $state, $dir) = @_;
311             my $hist_len = $self->{rl_history_length};
312             if ($hist_len > 0) {
313             $self->{rl_HistoryIndex} += $dir ;
314             if ($self->{rl_HistoryIndex} <= 0) {
315             $self->F_Ding();
316             $self->{rl_HistoryIndex} = 1;
317             return;
318             } elsif ($self->{rl_HistoryIndex} > $hist_len) {
319             $self->F_Ding();
320             $self->{rl_HistoryIndex} = $hist_len;
321             return;
322             }
323             $state->{buf} = $self->{rl_History}->[$self->{rl_HistoryIndex}-1];
324             $state->{pos} = $state->len;
325             $self->refresh_line($state);
326             }
327             }
328              
329             ########################################
330              
331             sub F_AcceptLine($) {
332             my $self = shift;
333             my $buf = $self->{state}->buf;
334             Term::ReadLine::Perl5::OO::History::add_history($self, $buf);
335             return (1, $buf);
336             }
337              
338             sub F_BackwardChar($) {
339             my $self = shift;
340             my $state = $self->{state};
341             if ($state->pos > 0) {
342             $state->{pos}--;
343             $self->refresh_line($state);
344             }
345             return undef, undef;
346             }
347              
348             sub F_BackwardDeleteChar($) {
349             my $self = shift;
350             my $state = $self->{state};
351             if ($state->pos > 0 && length($state->buf) > 0) {
352             substr($state->{buf}, $state->pos-1, 1) = '';
353             $state->{pos}--;
354             $self->refresh_line($state);
355             }
356             return undef, undef;
357             }
358              
359             sub F_BeginningOfLine($)
360             {
361             my $self = shift;
362             my $state = $self->{state};
363             $state->{pos} = 0;
364             $self->refresh_line($state);
365             return undef, undef;
366             }
367              
368             sub F_ClearScreen($) {
369             my $self = shift;
370             my $state = $self->{state};
371             print STDOUT "\x1b[H\x1b[2J";
372             return undef, undef;
373             $self->refresh_line($state);
374             }
375              
376             sub F_DeleteChar($) {
377             my $self = shift;
378             my $state = $self->{state};
379             if (length($state->buf) > 0) {
380             $self->edit_delete($state);
381             }
382             return undef, undef;
383             }
384              
385             sub F_EndOfLine($)
386             {
387             my $self = shift;
388             my $state = $self->{state};
389             $state->{pos} = length($state->buf);
390             $self->refresh_line($state);
391             return undef, undef;
392             }
393              
394             sub F_Ding($) {
395             my $self = shift;
396             Term::ReadLine::Perl5::Common::F_Ding(*STDERR);
397             return undef, undef;
398             }
399              
400             sub F_ForwardChar($) {
401             my $self = shift;
402             my $state = $self->{state};
403             if ($state->pos != length($state->buf)) {
404             $state->{pos}++;
405             $self->refresh_line($state);
406             }
407             return undef, undef;
408             }
409              
410             sub F_Interrupt() {
411             my $self = shift;
412             $self->{sigint}++;
413             return undef, undef;
414             }
415              
416             sub F_KillLine($)
417             {
418             my $self = shift;
419             my $state = $self->{state};
420             substr($state->{buf}, $state->{pos}) = '';
421             $self->refresh_line($state);
422             return undef, undef;
423             }
424              
425             sub F_NextHistory($) {
426             my $self = shift;
427             my $state = $self->{state};
428             $self->edit_history($state, HISTORY_NEXT);
429             return undef, undef;
430             }
431              
432             ##
433             ## Execute the next character input as a command in a meta keymap.
434             ##
435             sub F_PrefixMeta
436             {
437             my $self = shift;
438             my $cc = ord($self->{char});
439             $self->{current_keymap} = $self->{function}[$cc]->[1];
440             return undef, undef;
441             }
442              
443             sub F_PreviousHistory($) {
444             my $self = shift;
445             my $state = $self->{state};
446             $self->edit_history($state, HISTORY_PREV);
447             return undef, undef;
448             }
449              
450             sub F_ReverseSearchHistory($) {
451             my $self = shift;
452             my $state = $self->{state};
453             $self->search($state);
454             return undef, undef;
455             }
456              
457             sub F_SelfInsert($)
458             {
459             my $self = shift;
460             my $state = $self->{state};
461             my $c = $self->{char};
462             $self->debug("inserting ord($c)\n");
463             $self->edit_insert($state, $c);
464             # tuple[0] == '' signals not to eval function again
465             return '', undef;
466             }
467              
468             sub F_Suspend($)
469             {
470             my $self = shift;
471             my $state = $self->{state};
472             $self->{sigtstp}++;
473             return 1, $state->buf;
474             }
475              
476             # swaps current character with previous
477             sub F_TransposeChars($) {
478             my $self = shift;
479             my $state = $self->{state};
480             if ($state->pos > 0 && $state->pos < $state->len) {
481             my $aux = substr($state->buf, $state->pos-1, 1);
482             substr($state->{buf}, $state->pos-1, 1) = substr($state->{buf}, $state->pos, 1);
483             substr($state->{buf}, $state->pos, 1) = $aux;
484             if ($state->pos != $state->len -1) {
485             $state->{pos}++;
486             }
487             }
488             $self->refresh_line($state);
489             return undef, undef;
490             }
491              
492             sub F_UnixLineDiscard($)
493             {
494             my $self = shift;
495             my $state = $self->{state};
496             $state->{buf} = '';
497             $state->{pos} = 0;
498             $self->refresh_line($state);
499             return undef, undef;
500             }
501              
502             sub F_UnixRubout($)
503             {
504             my $self = shift;
505             my $state = $self->{state};
506             $self->edit_delete_prev_word($state);
507             return undef, undef;
508             }
509              
510             ########################################
511              
512             sub DESTROY {
513             shift->disable_raw_mode();
514             Term::ReadLine::Perl5::readline::ResetTTY;
515             }
516              
517             sub readline {
518             my ($self, $prompt) = @_;
519             $prompt = '> ' unless defined $prompt;
520             STDOUT->autoflush(1);
521              
522             local $Text::VisualWidth::PP::EastAsian = is_cjk_lang;
523              
524             if ($self->is_supported && -t STDIN) {
525             return $self->read_raw($prompt);
526             } else {
527             print STDOUT $prompt;
528             STDOUT->flush;
529             # I need to use ReadLine() to support Win32.
530             my $line = ReadLine(0);
531             $line =~ s/\n$// if defined $line;
532             return $line;
533             }
534             }
535              
536             sub get_columns {
537             my $self = shift;
538             my ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
539             return $wchar;
540             }
541              
542             sub readkey {
543             my $self = shift;
544             my $c = ReadKey(0);
545             return undef unless defined $c;
546             return $c unless $IS_WIN32;
547              
548             # Win32 API always return the bytes encoded with ACP. So it must be
549             # decoded from double byte sequence. To detect double byte sequence, it
550             # use Win32 API IsDBCSLeadByte.
551             require Win32::API;
552             require Encode;
553             require Term::Encoding;
554             $self->{isleadbyte} ||= Win32::API->new(
555             'kernel32', 'int IsDBCSLeadByte(char a)',
556             );
557             $self->{encoding} ||= Term::Encoding::get_encoding();
558             if ($self->{isleadbyte}->Call($c)) {
559             $c .= ReadKey(0);
560             $c = Encode::decode($self->{encoding}, $c);
561             }
562             $c;
563             }
564              
565             # linenoiseRaw
566             sub read_raw {
567             my ($self, $prompt) = @_;
568              
569             local $self->{sigint};
570             local $self->{sigtstp};
571             my $ret;
572             {
573             $self->enable_raw_mode();
574             $ret = $self->edit($prompt);
575             $self->disable_raw_mode();
576             }
577             print STDOUT "\n";
578             STDOUT->flush;
579             if ($self->{sigint}) {
580             kill 'INT', $$;
581             } elsif ($self->{sigtstp}) {
582             kill $IS_WIN32 ? 'INT' : 'TSTP', $$;
583             }
584             return $ret;
585             }
586              
587             sub enable_raw_mode {
588             my $self = shift;
589              
590             if ($IS_WIN32) {
591             ReadMode(5);
592             return undef;
593             }
594             my $termios = POSIX::Termios->new;
595             $termios->getattr(0);
596             $self->{rawmode} = [$termios->getiflag, $termios->getoflag, $termios->getcflag, $termios->getlflag, $termios->getcc(VMIN), $termios->getcc(VTIME)];
597             $termios->setiflag($termios->getiflag & ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON));
598             $termios->setoflag($termios->getoflag & ~(OPOST));
599             $termios->setcflag($termios->getcflag | ~(CS8));
600             $termios->setlflag($termios->getlflag & ~(ECHO|ICANON|IEXTEN | ISIG));
601             $termios->setcc(VMIN, 1);
602             $termios->setcc(VTIME, 0);
603             $termios->setattr(0, TCSAFLUSH);
604             return undef;
605             }
606              
607             sub disable_raw_mode {
608             my $self = shift;
609              
610             if ($IS_WIN32) {
611             ReadMode(0);
612             return undef;
613             }
614             if (my $r = delete $self->{rawmode}) {
615             my $termios = POSIX::Termios->new;
616             $termios->getattr(0);
617             $termios->setiflag($r->[0]);
618             $termios->setoflag($r->[1]);
619             $termios->setcflag($r->[2]);
620             $termios->setlflag($r->[3]);
621             $termios->setcc(VMIN, $r->[4]);
622             $termios->setcc(VTIME, $r->[5]);
623             $termios->setattr(0, TCSAFLUSH);
624             }
625             return undef;
626             }
627              
628             sub lookup_key($)
629             {
630             my ($self, $cc) = @_;
631             my $tuple = $self->{current_keymap}{function}->[$cc];
632             return $tuple if $tuple && defined($tuple->[0]);
633             my $fn_raw = $self->{current_keymap}{default};
634             my $fn = "F_${fn_raw}()";
635             print "+++", $fn, "\n";
636             my($done, $retval);
637             my $cmd = "(\$done, \$retval) = \$self->$fn";
638             # print $cmd, "\n";
639             eval($cmd);
640             return [$done, $retval];
641             }
642              
643             sub edit {
644             my ($self, $prompt) = @_;
645             print STDOUT $prompt;
646             STDOUT->flush;
647              
648             my $state = Term::ReadLine::Perl5::OO::State->new;
649             $state->{prompt} = $prompt;
650             $state->cols($self->get_columns);
651             $self->debug("Columns: $state->{cols}\n");
652             $self->{state} = $state;
653              
654             while (1) {
655             my $c = $self->readkey;
656             unless (defined $c) {
657             return $state->buf;
658             }
659             my $cc = ord($c) or next;
660              
661             if ($cc == TAB && defined $self->{completion_callback}) {
662             $c = $self->complete_line($state);
663             return undef unless defined $c;
664             $cc = ord($c);
665             next if $cc == 0;
666             }
667              
668             $self->{char} = $c;
669             my $tuple = $self->lookup_key($cc);
670             if ($tuple && $tuple->[0] ) {
671             my $fn = sprintf "F_%s()", $tuple->[0];
672             my($done, $retval);
673             ###### DEBUG ######
674             # if ($fn eq 'F_PrefixMeta()') {
675             # print "+++ Switching keymap\n";
676             # $self->{current_keymap} = $tuple->[1];
677             # next;
678             # }
679             my $cmd = "(\$done, \$retval) = \$self->$fn";
680             # use Data::Printer;
681             # print "+++ cmd:\n$cmd\n";
682             # p $tuple;
683             eval($cmd);
684             return $retval if $done;
685             } else {
686             # print "+++ Back to top\n";
687             $self->{current_keymap} = $self->{toplevel_keymap}
688             }
689              
690             # FIXME: When doing keymap lookup, I need a way to note that
691             # we want a return rather than to continue editing.
692             if ($cc == ESC) { # escape sequence
693             # Read the next two bytes representing the escape sequence
694             my $buf = $self->readkey or return undef;
695             $buf .= $self->readkey or return undef;
696              
697             if ($buf eq "[D") { # left arrow
698             $self->F_BackwardChar($state);
699             } elsif ($buf eq "[C") { # right arrow
700             $self->F_ForwardChar($state);
701             } elsif ($buf eq "[A") { # up arrow
702             $self->F_PreviousHistory($state);
703             } elsif ($buf eq "[B") { # down arrow
704             $self->F_NextHistory($state);
705             } elsif ($buf eq "[1") { # home
706             $buf = $self->readkey or return undef;
707             if ($buf eq '~') {
708             $state->{pos} = 0;
709             $self->refresh_line($state);
710             }
711             } elsif ($buf eq "[4") { # end
712             $buf = $self->readkey or return undef;
713             if ($buf eq '~') {
714             $state->{pos} = length($state->buf);
715             $self->refresh_line($state);
716             }
717             }
718             # TODO:
719             # else if (seq[0] == 91 && seq[1] > 48 && seq[1] < 55) {
720             # /* extended escape, read additional two bytes. */
721             # if (read(fd,seq2,2) == -1) break;
722             # if (seq[1] == 51 && seq2[0] == 126) {
723             # /* Delete key. */
724             # linenoiseEditDelete(&l);
725             # }
726             # }
727             }
728             }
729             return $state->buf;
730             }
731              
732             sub edit_delete {
733             my ($self, $status) = @_;
734             if ($status->len > 0 && $status->pos < $status->len) {
735             substr($status->{buf}, $status->pos, 1) = '';
736             $self->refresh_line($status);
737             }
738             }
739              
740             sub search {
741             my ($self, $state) = @_;
742              
743             my $query = '';
744             local $state->{query} = '';
745             LOOP:
746             while (1) {
747             my $c = $self->readkey;
748             unless (defined $c) {
749             return $state->buf;
750             }
751             my $cc = ord($c) or next;
752              
753             if (
754             $cc == CTRL_B
755             || $cc == CTRL_C
756             || $cc == CTRL_F
757             || $cc == ENTER
758             ) {
759             return;
760             }
761             if ($cc == BACKSPACE || $cc == CTRL_H) {
762             $self->debug("ctrl-h in searching\n");
763             $query =~ s/.\z//;
764             } else {
765             $query .= $c;
766             }
767             $self->debug("C: $cc\n");
768              
769             $state->query($query);
770             $self->debug("Searching '$query'\n");
771             SEARCH:
772             for my $hist (@{$self->history}) {
773             if ((my $idx = index($hist, $query)) >= 0) {
774             $state->buf($hist);
775             $state->pos($idx);
776             $self->refresh_line($state);
777             next LOOP;
778             }
779             }
780             $self->F_Ding();
781             $self->refresh_line($state);
782             }
783             }
784              
785             sub complete_line {
786             my ($self, $state) = @_;
787              
788             my @ret = grep { defined $_ } $self->{completion_callback}->($state->buf);
789             unless (@ret) {
790             $self->F_Ding();
791             return "\0";
792             }
793              
794             my $i = 0;
795             while (1) {
796             # Show completion or original buffer
797             if ($i < @ret) {
798             my $cloned = Storable::dclone($state);
799             $cloned->{buf} = $ret[$i];
800             $cloned->{pos} = length($cloned->{buf});
801             $self->refresh_line($cloned);
802             } else {
803             $self->refresh_line($state);
804             }
805              
806             my $c = $self->readkey;
807             unless (defined $c) {
808             return undef;
809             }
810             my $cc = ord($c) or next;
811              
812             if ($cc == TAB) { # tab
813             $i = ($i+1) % (1+@ret);
814             if ($i==@ret) {
815             $self->F_Ding();
816             }
817             } elsif ($cc == ESC) { # escape
818             # Re-show original buffer
819             if ($i<@ret) {
820             $self->refresh_line($state);
821             }
822             return $c;
823             } else {
824             # Update buffer and return
825             if ($i<@ret) {
826             $state->{buf} = $ret[$i];
827             $state->{pos} = length($state->{buf});
828             }
829             return $c;
830             }
831             }
832             }
833              
834             unless (caller()) {
835             my $c = __PACKAGE__->new;
836             if (@ARGV) {
837             while (defined(my $line = $c->readline($ARGV[0] .'> '))) {
838             if ($line =~ /\S/) {
839             print eval $line, "\n";
840             }
841             }
842             }
843             }
844              
845             sub MinLine($;$) {
846             my $self = $_[0];
847             my $old = $self->{minlength};
848             $self->{minlength} = $_[1] if @_ == 2;
849             return $old;
850             }
851              
852             1;
853             __END__