diff options
author | Ricardo Signes <rjbs@cpan.org> | 2012-03-09 11:03:10 -0500 |
---|---|---|
committer | Ricardo Signes <rjbs@cpan.org> | 2012-03-09 11:03:10 -0500 |
commit | 7f6006a6198eab15e3efbd31ae5f604358da742f (patch) | |
tree | 7c7df51e1a1044c3af5ff6f82ddef2f6e3fbedb3 | |
parent | a752ff79ee1321f459c659136b0f0e7e43e1f5ae (diff) | |
download | perl-rjbs/readline-loop.tar.gz |
more Readline/event code from Darin McBriderjbs/readline-loop
-rw-r--r-- | dist/Term-ReadLine/lib/Term/ReadLine.pm | 154 | ||||
-rw-r--r-- | dist/Term-ReadLine/t/TkExternal.t | 59 |
2 files changed, 86 insertions, 127 deletions
diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm index 7262596a50..3cf4bd4743 100644 --- a/dist/Term-ReadLine/lib/Term/ReadLine.pm +++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -111,12 +111,38 @@ additional methods: =item C<tkRunning> -makes Tk's event loop run when waiting for user input (i.e., during -the C<readline> method). +makes Tk event loop run when waiting for user input (i.e., during +C<readline> method). -Term::ReadLine supports any event loop, including unpubished ones and -simple IO::Select loops without the need to rewrite existing code for -any particular framework. See IN(), print_prompt(), and get_line(). +=item C<event_loop> + +Registers call-backs to wait for user input (i.e., during C<readline> +method). This supercedes tkRunning. + +The first call-back registered is the call back for waiting. It is +expected that the callback will call the current event loop until +there is something waiting to get on the input filehandle. + +The second call-back registered is the call back for registration. The +input filehandle (often STDIN, but not necessarily) will be passed in. + +For example, with AnyEvent: + + my ($cv, $fe); + $term->event_loop(sub { + $cv = AE::cv(); + $cv->recv(); + }, sub { + my $fh = shift; + $fe ||= AE::io($fh, 0, sub { $cv->send() }); + }); + +Note that $fe must not go out of scope while $term is still in scope, +or the io watcher will terminate. Similar concerns may exist for other +event loops. + +The second call-back is optional if you register your callback prior to +the call to $term-E<gt>readline. =item C<ornaments> @@ -131,59 +157,11 @@ standout, last two to make the input line standout. takes two arguments which are input filehandle and output filehandle. Switches to use these filehandles. -=item C<print_prompt> - -prints a prompt and returns immediately. readline() uses it to print -its prompt before calling get_line(). See L</"Using Event Loops"> for -an example of its use. - -=item C<get_line> - -gets a line of input from the terminal. If Tk is used and tkRunning() -has been set, then get_line() will dispatch Tk events while waiting -for a line of input. The full readline() API is a print_prompt() call -followed immediately by get_input(). See L</"Using Event Loops">. - =back One can check whether the currently loaded ReadLine package supports these methods by checking for corresponding C<Features>. -=head1 Using Event Loops - -Term::ReadLine provides IN(), print_prompt(), and get_line() so that -it may be used by any event loop that can watch for input on a file -handle. This includes most event loops including ones that haven't -been published. - -Term::ReadLine's readline() method prints a prompt and returns a line -of input got from its input filehandle: - - sub readline { - my ($self,$prompt) = @_; - $self->print_prompt($prompt); - $self->get_line(); - } - -A Tk readline function may be implemented by having Tk dispatch its -own events between the time the prompt is printed and the line is got. -This example function dispatches Tk events while Term::ReadLine waits -for console input. It can completely replace Term::ReadLine's -existing Tk support. - - sub tk_read_line { - my ($term, $prompt) = @_; - $term->print_prompt($prompt); - - my $got_input; - Tk->fileevent($term->IN, 'readable', sub { $got_input = 1 }); - Tk::DoOneEvent(0) until $got_input; - - return $term->get_line(); - } - -Other event loops are equally possible. - =head1 EXPORTS None @@ -219,17 +197,25 @@ $DB::emacs = $DB::emacs; # To peacify -w our @rl_term_set; *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; -sub print_prompt { - my ($self, $prompt) = @_; - my $out = $self->[1]; - print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; -} +sub PERL_UNICODE_STDIN () { 0x0001 } sub ReadLine {'Term::ReadLine::Stub'} sub readline { - my ($self,$prompt) = @_; - $self->print_prompt($prompt); - $self->get_line(); + my $self = shift; + my ($in,$out,$str) = @$self; + my $prompt = shift; + print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; + $self->register_Tk + if not $Term::ReadLine::registered and $Term::ReadLine::toloop; + #$str = scalar <$in>; + $str = $self->get_line; + utf8::upgrade($str) + if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) && + utf8::valid($str); + print $out $rl_term_set[3]; + # bug in 5.000: chomping empty string creats length -1: + chomp $str if defined $str; + $str; } sub addhistory {} @@ -407,22 +393,35 @@ package Term::ReadLine::Tk; # the$term->IN() accessor becomes ready for reading. It's assumed # that the diamond operator will return a line of input immediately at # that point. -# -# Any event loop can use $term-IN() and $term->readline() directly -# without adding code for any event loop specifically to this. my ($giveup); # maybe in the future the Tk-specific aspects will be removed. sub Tk_loop{ - Tk::DoOneEvent(0) until $giveup; - $giveup = 0; + if (ref $Term::ReadLine::toloop) + { + $Term::ReadLine::toloop->[0]->(); + } + else + { + Tk::DoOneEvent(0) until $giveup; + $giveup = 0; + } }; sub register_Tk { my $self = shift; - $Term::ReadLine::registered++ - or Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); + unless ($Term::ReadLine::registered++) + { + if (ref $Term::ReadLine::toloop) + { + $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1]; + } + else + { + Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); + } + } }; sub tkRunning { @@ -430,6 +429,25 @@ sub tkRunning { $Term::ReadLine::toloop; } +sub event_loop { + shift; + + # T::RL::Gnu and T::RL::Perl check that this exists, if not, + # it doesn't call the loop. Those modules will need to be + # fixed before this can be removed. + if (not defined &Tk::DoOneEvent) + { + *Tk::DoOneEvent = sub { + die "what?"; # this shouldn't be called. + } + } + + # store the callback in toloop, again so that other modules will + # recognise it and call us for the loop. + $Term::ReadLine::toloop = [ @_ ] if @_ > 1; + $Term::ReadLine::toloop; +} + sub PERL_UNICODE_STDIN () { 0x0001 } sub get_line { diff --git a/dist/Term-ReadLine/t/TkExternal.t b/dist/Term-ReadLine/t/TkExternal.t deleted file mode 100644 index 7c4cf69773..0000000000 --- a/dist/Term-ReadLine/t/TkExternal.t +++ /dev/null @@ -1,59 +0,0 @@ -#!perl - -use Test::More; - -eval "use Tk; 1" or - plan skip_all => "Tk is not installed."; - -# seeing as the entire point of this test is to test the event handler, -# we need to mock as little as possible. To keep things tightly controlled, -# we'll use the Stub directly. -BEGIN { - $ENV{PERL_RL} = 'Stub o=0'; -} - -my $mw; -eval { - use File::Spec; - $mw = MainWindow->new(); $mw->withdraw(); - 1; -} or plan skip_all => "Tk can't start. DISPLAY not set?"; - -# need to delay this so that Tk is loaded first. -require Term::ReadLine; - -plan tests => 3; - -my $t = Term::ReadLine->new('Tk'); -ok($t, "Created object"); -is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); - -# This test will dispatch Tk events externally. -$t->tkRunning(0); - -my $text = 'some text'; -my $T = $text . "\n"; - -my $w = Tk::after($mw,0, - sub { - pass("Event loop called"); - exit 0; - }); - -my $result = tk_readline($t, 'Do not press enter>'); -fail("Should not get here."); - -# A Tk-dispatching readline that doesn't require Tk (or any other -# event loop) support to be hard-coded into Term::ReadLine. - -sub tk_readline { - my ($term, $prompt) = @_; - - $term->print_prompt($prompt); - - my $got_input; - Tk->fileevent($term->IN, 'readable', sub { $got_input = 1 }); - Tk::DoOneEvent(0) until $got_input; - - return $term->get_line(); -} |