1 |
root |
1.1 |
=head1 NAME |
2 |
|
|
|
3 |
|
|
AnyEvent::ReadLine - simple but versatile readline implementation |
4 |
|
|
|
5 |
|
|
=head1 SYNOPSIS |
6 |
|
|
|
7 |
|
|
use AnyEvent::ReadLine; |
8 |
|
|
|
9 |
|
|
=head1 DESCRIPTION |
10 |
|
|
|
11 |
|
|
This module implements some kind of readline interface - something that |
12 |
|
|
allows you to read a (command-) line entered by the user, and allows the |
13 |
|
|
user to comfortably (hopefully) edit it. |
14 |
|
|
|
15 |
|
|
Basically, this module implements something like perl's C<readline> |
16 |
|
|
function, except potentially with user editing. |
17 |
|
|
|
18 |
|
|
There are a multitude of readline modules and -implementations available |
19 |
|
|
for Perl. The difference of this module to others is that it takes pipes, |
20 |
|
|
network sockets and other generic file handles into account, in addition |
21 |
|
|
to traditional tty interfaces. |
22 |
|
|
|
23 |
|
|
=over 4 |
24 |
|
|
|
25 |
|
|
=cut |
26 |
|
|
|
27 |
|
|
package AnyEvent::ReadLine; |
28 |
|
|
|
29 |
|
|
use common::sense; |
30 |
|
|
use Scalar::Util (); |
31 |
|
|
use Errno (); |
32 |
|
|
use Term::Terminfo (); |
33 |
|
|
use AnyEvent; |
34 |
|
|
|
35 |
|
|
our $VERSION = '0.0'; |
36 |
|
|
|
37 |
|
|
=item $rl = new AnyEvent::ReadLine key => value... |
38 |
|
|
|
39 |
|
|
Creates a new AnyEvent::ReadLine object. |
40 |
|
|
|
41 |
|
|
The key value pairs that are understood are the following: |
42 |
|
|
|
43 |
|
|
=over 4 |
44 |
|
|
|
45 |
|
|
=item fh => $fh |
46 |
|
|
|
47 |
|
|
The file handle used to read user input from. |
48 |
|
|
|
49 |
|
|
=item ofh => $fh |
50 |
|
|
|
51 |
|
|
The file handle used to write feedback to - defaults to C<fh>. |
52 |
|
|
|
53 |
|
|
=item mode => "none"|"termios"|"telnet" |
54 |
|
|
|
55 |
|
|
Governs how the terminal is driven. Defaults to C<termios> when |
56 |
|
|
C<fh> is connected to a tty, C<none> otherwise. |
57 |
|
|
|
58 |
|
|
=item term => $terminfo |
59 |
|
|
|
60 |
|
|
The terminfo name of the attached terminal - in termios mode, defaults |
61 |
|
|
to C<$ENV{TERM}>, otherwise the default is C<ansi> which works in most |
62 |
|
|
situations. |
63 |
|
|
|
64 |
|
|
=item prompt => $prompt |
65 |
|
|
|
66 |
|
|
The prompt string to use (default: C<< > >>). C<$prompt> can also be |
67 |
|
|
a code reference that returns the prompt, and will be called on every |
68 |
|
|
redisplay. |
69 |
|
|
|
70 |
|
|
=item timeout => $seconds |
71 |
|
|
|
72 |
|
|
After how many seconds a key sequence is considered complete. To |
73 |
|
|
differentiate between, say, the escape key and typical arrow key sequences |
74 |
|
|
a timeout needs to be used. The default is 0.02 in termios mode, and 0.1 |
75 |
|
|
in all others. |
76 |
|
|
|
77 |
|
|
=item encoding => $encoding |
78 |
|
|
|
79 |
|
|
The encoding of the terminal. Only "utf-8" and "iso-8859-1" are supported |
80 |
|
|
at the moment, because Perl apparently has no incremental decoding |
81 |
|
|
facilities (Encode can't do it, perlio can't do it). |
82 |
|
|
|
83 |
|
|
The default is utf-8, until I can find out how to detect if a filehandle |
84 |
|
|
is in utf-8 mode without resorting to undocumented functionality. |
85 |
|
|
|
86 |
|
|
=item width => $width |
87 |
|
|
|
88 |
|
|
=item height => $height |
89 |
|
|
|
90 |
|
|
The width and height of the screen - these will be updated to the true |
91 |
|
|
widht and height if possible. |
92 |
|
|
|
93 |
|
|
=item on_read => $cb->($rl, $string) |
94 |
|
|
|
95 |
|
|
Called each time the user is finished entering a line. The string is in |
96 |
|
|
unicode format. |
97 |
|
|
|
98 |
|
|
=item on_eof => $cb->($rl) |
99 |
|
|
|
100 |
|
|
Called when an EOF is detected on the input file handle. Must eventually |
101 |
|
|
destroy the object. |
102 |
|
|
|
103 |
|
|
=item on_error => $cb->($rl, "$!") |
104 |
|
|
|
105 |
|
|
Called on any unhandled error that occured. Second argument is a string |
106 |
|
|
describing the saituation, C<$!> contains the actual error. |
107 |
|
|
|
108 |
|
|
=item on_change => $cb->($rl, $string, $pos) |
109 |
|
|
|
110 |
|
|
When specified, C<ofh> is ignored - each time the presentation changes, |
111 |
|
|
this callback is called with the string to display (including any prompt) |
112 |
|
|
and the position of the cursor inside the string. |
113 |
|
|
|
114 |
|
|
The string is in unicode (and thus C<$pos> is a character position) - to |
115 |
|
|
output it, you normally must encode it first. |
116 |
|
|
|
117 |
|
|
=item on_key_XXX => $cb->($rl, $key) |
118 |
|
|
|
119 |
|
|
Each time a key XXX in the keymap is entered, this callback will be |
120 |
|
|
invoked if it exists. It may want to invoke the original C<key_XXX> |
121 |
|
|
method. |
122 |
|
|
|
123 |
|
|
=back |
124 |
|
|
|
125 |
|
|
=cut |
126 |
|
|
|
127 |
|
|
sub new { |
128 |
|
|
my $class = shift; |
129 |
|
|
|
130 |
|
|
my $self = bless { |
131 |
|
|
prompt => "> ", |
132 |
|
|
@_, |
133 |
|
|
raw => 0, |
134 |
|
|
}, $class; |
135 |
|
|
|
136 |
|
|
$self->{ofh} ||= $self->{fh}; |
137 |
|
|
$self->{mode} ||= -t $self->{fh} ? "termios" : "none"; |
138 |
|
|
|
139 |
|
|
$self->{timeout} ||= $self->{mode} eq "termios" ? 0.02 : 0.1; |
140 |
|
|
$self->{encoding} ||= "utf-8"; |
141 |
|
|
|
142 |
|
|
$self->set_term ((delete $self->{term}) || ($self->{mode} eq "termios" && $ENV{TERM}) || "ansi"); |
143 |
|
|
|
144 |
|
|
{ |
145 |
|
|
Scalar::Util::weaken (my $self = $self); |
146 |
|
|
|
147 |
|
|
$self->{tcb} = sub { |
148 |
|
|
delete $self->{tw}; |
149 |
|
|
$self->feed; |
150 |
|
|
}; |
151 |
|
|
|
152 |
|
|
$self->{rcb} = sub { |
153 |
|
|
my $len = sysread $self->{fh}, $self->{rbuf}, 1, length $self->{rbuf}; |
154 |
|
|
if ($len) { |
155 |
|
|
$self->{tw} = AE::timer $self->{timeout}, 0, $self->{tcb}; |
156 |
|
|
} elsif (defined $len) { |
157 |
|
|
$self->{on_eof} |
158 |
|
|
? $self->{on_eof}($self) |
159 |
|
|
: $self->{on_error}($self, 0, "unexpected end of file"); |
160 |
|
|
} elsif ($! != Errno::EAGAIN && $! != Errno::EINTR) { |
161 |
|
|
$self->{on_error}($self, $!, "$!"); |
162 |
|
|
} |
163 |
|
|
}; |
164 |
|
|
|
165 |
|
|
$self->{wcb} = sub { |
166 |
|
|
my $len = syswrite $self->{ofh}, $self->{wbuf}; |
167 |
|
|
substr $self->{wbuf}, 0, $len, ""; |
168 |
|
|
delete $self->{ww} unless length $self->{wbuf}; |
169 |
|
|
# todo error handling |
170 |
|
|
}; |
171 |
|
|
} |
172 |
|
|
|
173 |
|
|
$self->enable; |
174 |
|
|
|
175 |
|
|
$self |
176 |
|
|
} |
177 |
|
|
|
178 |
|
|
sub DESTROY { |
179 |
|
|
my ($self) = @_; |
180 |
|
|
|
181 |
|
|
$self->disable; |
182 |
|
|
} |
183 |
|
|
|
184 |
|
|
sub default_keymap { |
185 |
|
|
my ($self) = @_; |
186 |
|
|
|
187 |
|
|
my %keymap; |
188 |
|
|
|
189 |
|
|
for (0..31) { |
190 |
|
|
$keymap{chr $_ } = "ctrl$_"; |
191 |
|
|
$keymap{chr $_ + 128} = "hctrl$_"; |
192 |
|
|
} |
193 |
|
|
|
194 |
|
|
$keymap{"\x03"} = "intr"; |
195 |
|
|
$keymap{"\x04"} = "eof"; |
196 |
|
|
$keymap{"\x08"} = "backspace"; # common |
197 |
|
|
$keymap{"\x0a"} = "enter"; |
198 |
|
|
$keymap{"\x0c"} = "redraw"; |
199 |
|
|
$keymap{"\x0d"} = "enter"; |
200 |
|
|
$keymap{"\x15"} = "kill"; |
201 |
|
|
$keymap{"\x17"} = "werase"; |
202 |
|
|
$keymap{"\x1a"} = "susp"; |
203 |
|
|
$keymap{"\x1b"} = "esc"; |
204 |
|
|
$keymap{"\x1c"} = "quit"; |
205 |
|
|
$keymap{"\x7f"} = "backspace"; # correct |
206 |
|
|
|
207 |
|
|
if (my $ti = $self->{ti}) { |
208 |
|
|
# for my $func (qw(up down left right enter backspace dc)) { |
209 |
|
|
# $keymap{$ti->str_by_varname ("key_$func")} = $func; |
210 |
|
|
# } |
211 |
|
|
# we bind all keys that have known sequences, to avoid |
212 |
|
|
# inserting their raw codes when we don't understand them |
213 |
|
|
for my $key (grep s/^key_//, $ti->str_varnames) { |
214 |
|
|
my $str = $ti->str_by_varname ("key_$key"); |
215 |
|
|
$key =~ y/a-z0-9_//cd; # increase security - these are used for method calls |
216 |
|
|
$keymap{$str} = $key; |
217 |
|
|
} |
218 |
|
|
} |
219 |
|
|
|
220 |
|
|
if ($self->{mode} eq "termios") { |
221 |
|
|
require POSIX; |
222 |
|
|
|
223 |
|
|
my $tio = POSIX::Termios->new; |
224 |
|
|
if ($tio->getattr (fileno $self->{fh})) { |
225 |
|
|
$keymap{chr $tio->getcc (&POSIX::VINTR )} = "intr"; |
226 |
|
|
$keymap{chr $tio->getcc (&POSIX::VSUSP )} = "susp"; |
227 |
|
|
$keymap{chr $tio->getcc (&POSIX::VEOF )} = "eof"; |
228 |
|
|
$keymap{chr $tio->getcc (&POSIX::VEOL )} = "enter"; |
229 |
|
|
$keymap{chr $tio->getcc (&POSIX::VKILL )} = "kill"; |
230 |
|
|
$keymap{chr $tio->getcc (&POSIX::VERASE)} = "backspace"; |
231 |
|
|
$keymap{chr $tio->getcc (&POSIX::VQUIT )} = "quit"; |
232 |
|
|
} |
233 |
|
|
} |
234 |
|
|
|
235 |
|
|
# delete some garbage the above might create |
236 |
|
|
delete $keymap{""}; |
237 |
|
|
delete $keymap{"\0"}; |
238 |
|
|
|
239 |
|
|
# keymap MUST be nonempty (which must be the case by now) |
240 |
|
|
|
241 |
|
|
$self->{keymap} = \%keymap; |
242 |
|
|
delete $self->{ckm}; |
243 |
|
|
} |
244 |
|
|
|
245 |
|
|
sub set_term { |
246 |
|
|
my ($self, $term) = @_; |
247 |
|
|
|
248 |
|
|
return if $self->{term} eq $term; |
249 |
|
|
|
250 |
|
|
$self->{term} = $term; |
251 |
|
|
$self->{ti} = new Term::Terminfo $term; |
252 |
|
|
|
253 |
|
|
$self->default_keymap; |
254 |
|
|
} |
255 |
|
|
|
256 |
|
|
sub enable { |
257 |
|
|
my ($self) = @_; |
258 |
|
|
|
259 |
|
|
return if $self->{raw}; |
260 |
|
|
|
261 |
|
|
if ($self->{mode} eq "termios") { |
262 |
|
|
require POSIX; |
263 |
|
|
|
264 |
|
|
$self->{tio} = POSIX::Termios->new; |
265 |
|
|
$self->{tio}->getattr (fileno $self->{fh}) |
266 |
|
|
or return; |
267 |
|
|
|
268 |
|
|
my $tio = POSIX::Termios->new; |
269 |
|
|
$tio->getattr (fileno $self->{fh}) |
270 |
|
|
or return; |
271 |
|
|
|
272 |
|
|
$tio->setiflag ($tio->getiflag |
273 |
|
|
& ~&POSIX::BRKINT |
274 |
|
|
& ~&POSIX::IGNBRK |
275 |
|
|
& ~&POSIX::ISTRIP |
276 |
|
|
); |
277 |
|
|
$tio->setlflag ($tio->getlflag |
278 |
|
|
& ~&POSIX::ECHO |
279 |
|
|
& ~&POSIX::ECHONL |
280 |
|
|
& ~&POSIX::ICANON |
281 |
|
|
# & ~&POSIX::ISIG #d# |
282 |
|
|
); |
283 |
|
|
|
284 |
|
|
$tio->setattr (fileno $self->{fh}); |
285 |
|
|
} |
286 |
|
|
|
287 |
|
|
$self->line_draw unless $self->{on_change}; |
288 |
|
|
|
289 |
|
|
$self->{rw} = AE::io $self->{fh}, 0, $self->{rcb}; |
290 |
|
|
|
291 |
|
|
$self->{raw} = 1; |
292 |
|
|
} |
293 |
|
|
|
294 |
|
|
sub disable { |
295 |
|
|
my ($self) = @_; |
296 |
|
|
|
297 |
|
|
return unless $self->{raw}; |
298 |
|
|
|
299 |
|
|
$self->line_erase unless $self->{on_change}; |
300 |
|
|
|
301 |
|
|
delete $self->{rw}; |
302 |
|
|
|
303 |
|
|
if ($self->{mode} eq "termios") { |
304 |
|
|
(delete $self->{tio})->setattr (fileno $self->{fh}); |
305 |
|
|
} |
306 |
|
|
|
307 |
|
|
$self->{raw} = 0; |
308 |
|
|
} |
309 |
|
|
|
310 |
|
|
sub strwidth { |
311 |
|
|
scalar (my @dummy = $_[0] =~ /\p{Print}/g) |
312 |
|
|
- scalar (my @dummy = $_[0] =~ /\p{Mark}/g) |
313 |
|
|
+ scalar (my @dummy = $_[0] =~ /\p{East_Asian_Width=Wide}/g) |
314 |
|
|
} |
315 |
|
|
|
316 |
|
|
sub write { |
317 |
|
|
my ($self, $data) = @_; |
318 |
|
|
|
319 |
|
|
$self->{wbuf} .= $data; |
320 |
|
|
|
321 |
|
|
$self->{ww} ||= AE::io $self->{ofh}, 1, $self->{wcb}; |
322 |
|
|
} |
323 |
|
|
|
324 |
|
|
sub line_erase { |
325 |
|
|
my ($self) = @_; |
326 |
|
|
|
327 |
|
|
$self->write ( |
328 |
|
|
("\x08" x $self->{bpos}) |
329 |
|
|
. (" " x $self->{blen}) |
330 |
|
|
. ("\x08" x $self->{blen}) |
331 |
|
|
); |
332 |
|
|
|
333 |
|
|
$self->{bpos} = 0; |
334 |
|
|
$self->{blen} = 0; |
335 |
|
|
} |
336 |
|
|
|
337 |
|
|
sub line_draw { |
338 |
|
|
my ($self) = @_; |
339 |
|
|
|
340 |
|
|
my $prompt = $self->{prompt}; |
341 |
|
|
$prompt = $prompt->($self) if ref $prompt; |
342 |
|
|
|
343 |
|
|
my $l = $prompt . substr $self->{lbuf}, 0, $self->{pos}; |
344 |
|
|
my $r = substr $self->{lbuf}, $self->{pos}; |
345 |
|
|
|
346 |
|
|
for ($l, $r) { |
347 |
|
|
s/(\P{Print})/sprintf "\\x{%x}", ord $1/ge; |
348 |
|
|
} |
349 |
|
|
|
350 |
|
|
my $wl = strwidth $l; |
351 |
|
|
my $wr = strwidth $r; |
352 |
|
|
|
353 |
|
|
$self->{blen} = $wl + $wr + 6; # erase a bit more, to feel better |
354 |
|
|
$self->{bpos} = $wl; |
355 |
|
|
|
356 |
|
|
my $buf = $prompt . $self->{lbuf}; |
357 |
|
|
|
358 |
|
|
utf8::encode $buf if $self->{encoding} eq "utf-8"; |
359 |
|
|
|
360 |
|
|
$self->write ($buf . ("\x08" x $wr)); |
361 |
|
|
} |
362 |
|
|
|
363 |
|
|
sub refresh { |
364 |
|
|
my ($self) = @_; |
365 |
|
|
|
366 |
|
|
if ($self->{on_change}) { |
367 |
|
|
$self->{on_change}($self, $self->{lbuf}, $self->{pos}); |
368 |
|
|
} else { |
369 |
|
|
$self->line_erase; |
370 |
|
|
$self->line_draw; |
371 |
|
|
} |
372 |
|
|
} |
373 |
|
|
|
374 |
|
|
sub msg { |
375 |
|
|
my ($self, $msg) = @_; |
376 |
|
|
|
377 |
|
|
return if $self->{on_change}; |
378 |
|
|
|
379 |
|
|
$self->disable; |
380 |
|
|
$self->write ("$msg\x0d\x0a"); |
381 |
|
|
$self->enable; |
382 |
|
|
} |
383 |
|
|
|
384 |
|
|
sub feed { |
385 |
|
|
my ($self) = @_; |
386 |
|
|
|
387 |
|
|
# TODO: telnet |
388 |
|
|
|
389 |
|
|
# decode the input bytes into unicode |
390 |
|
|
|
391 |
|
|
if ($self->{encoding} eq "utf-8") { |
392 |
|
|
while ($self->{rbuf} =~ s/^([\x00-\x7f]|[\x80-\xff]+)//) { |
393 |
|
|
my $c = $1; |
394 |
|
|
utf8::decode $c; # if fails, we use $c as-is |
395 |
|
|
$self->{input} .= $c; |
396 |
|
|
} |
397 |
|
|
} else { |
398 |
|
|
$self->{input} .= delete $self->{rbuf}; |
399 |
|
|
} |
400 |
|
|
|
401 |
|
|
# compile keymap, if not done yet |
402 |
|
|
|
403 |
|
|
$self->{ckm} ||= do { |
404 |
|
|
# compile keymap |
405 |
|
|
my $re = join "|", map quotemeta, reverse sort keys %{ $self->{keymap} }; |
406 |
|
|
qr<^($re)> |
407 |
|
|
}; |
408 |
|
|
|
409 |
|
|
# now try to match input sequences |
410 |
|
|
|
411 |
|
|
for ($self->{input}) { |
412 |
|
|
while () { |
413 |
|
|
if (s/$self->{ckm}//) { |
414 |
|
|
if (my $key = $self->{keymap}{$1}) { |
415 |
|
|
($self->{"on_$key"} |
416 |
|
|
|| (UNIVERSAL::can $self, "key_$key") |
417 |
|
|
|| sub { $self->msg ("$_[1]: unsupported key") } |
418 |
|
|
)->($self, $key); |
419 |
|
|
} |
420 |
|
|
} elsif (s/^(.)//) { |
421 |
|
|
substr $self->{lbuf}, $self->{pos}, 0, $1; |
422 |
|
|
$self->{pos} += length $1; # always 1 |
423 |
|
|
|
424 |
|
|
$self->refresh; |
425 |
|
|
} else { |
426 |
|
|
last; |
427 |
|
|
} |
428 |
|
|
} |
429 |
|
|
} |
430 |
|
|
} |
431 |
|
|
|
432 |
|
|
############################################################################# |
433 |
|
|
|
434 |
|
|
my $rl = new AnyEvent::ReadLine |
435 |
|
|
fh => \*STDIN, |
436 |
|
|
ofh => \*STDOUT, |
437 |
|
|
term => "ansi", |
438 |
|
|
prompt => sub { AE::time . "> " }, |
439 |
|
|
on_eof => sub { die "eof" }, |
440 |
|
|
on_error => sub { die "<@_>" }, |
441 |
|
|
; |
442 |
|
|
|
443 |
|
|
my $t = AE::timer 5, 0, sub { $rl->disable; exit }; |
444 |
|
|
$rl->enable; |
445 |
|
|
|
446 |
|
|
AE::cv->recv; |
447 |
|
|
|
448 |
|
|
1; |
449 |
|
|
|
450 |
|
|
=back |
451 |
|
|
|
452 |
|
|
=head1 AUTHOR AND CONTACT |
453 |
|
|
|
454 |
|
|
Marc Lehmann <schmorp@schmorp.de> |
455 |
|
|
http://software.schmorp.de/pkg/AnyEvent-Readline.html |
456 |
|
|
|
457 |
|
|
=cut |
458 |
|
|
|