From fc013e910ecb5926cbd4a39a00ef6428372a82a1 Mon Sep 17 00:00:00 2001 From: Max Maischein Date: Sun, 19 Feb 2012 14:09:55 +0100 Subject: [PATCH] Refactor the Tk event loop to allow for other event loops 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. --- dist/Term-ReadLine/lib/Term/ReadLine.pm | 175 ++++++++++++++---------- dist/Term-ReadLine/t/AE.t | 33 ----- dist/Term-ReadLine/t/AETk.t | 42 ------ dist/Term-ReadLine/t/TkExternal.t | 59 ++++++++ 4 files changed, 161 insertions(+), 148 deletions(-) delete mode 100644 dist/Term-ReadLine/t/AE.t delete mode 100644 dist/Term-ReadLine/t/AETk.t create mode 100644 dist/Term-ReadLine/t/TkExternal.t diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm index aead1cc65a0d..7262596a50de 100644 --- a/dist/Term-ReadLine/lib/Term/ReadLine.pm +++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -111,9 +111,12 @@ additional methods: =item C -makes an event loop run when waiting for user input (i.e., during -C method). If AnyEvent is loaded, it is used, otherwise Tk -is used. +makes Tk's event loop run when waiting for user input (i.e., during +the C 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 @@ -128,11 +131,59 @@ 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 + +prints a prompt and returns immediately. readline() uses it to print +its prompt before calling get_line(). See L for +an example of its use. + +=item C + +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. + =back One can check whether the currently loaded ReadLine package supports these methods by checking for corresponding C. +=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 @@ -168,25 +219,17 @@ $DB::emacs = $DB::emacs; # To peacify -w our @rl_term_set; *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; -sub PERL_UNICODE_STDIN () { 0x0001 } +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 ReadLine {'Term::ReadLine::Stub'} sub readline { - 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; + my ($self,$prompt) = @_; + $self->print_prompt($prompt); + $self->get_line(); } sub addhistory {} @@ -359,70 +402,56 @@ sub ornaments { package Term::ReadLine::Tk; -# if AnyEvent is loaded, use it. -#use Enbugger; Enbugger->stop; -if (defined &AE::cv) -{ - my ($cv, $fe); - - # maintain old name for backward-compatibility - *AE_loop = *Tk_loop = sub { - my $self = shift; - $cv = AE::cv(); - $cv->recv(); - }; - - *register_AE = *register_Tk = sub { - my $self = shift; - $fe ||= AE::io($self->IN, 0, sub { $cv->send() }); - }; - - # just because AE is loaded doesn't mean Tk isn't. - if (not defined &Tk::DoOneEvent) - { - # create the stub as some T::RL implementations still check - # this directly. This should eventually be removed. - *Tk::DoOneEvent = sub { - die "should not happen"; - }; - } -} -else -{ - my ($giveup); - - # technically, not AE, but maybe in the future the Tk-specific - # aspects will be removed. - *AE_loop = *Tk_loop = sub { - Tk::DoOneEvent(0) until $giveup; - $giveup = 0; - }; - - *register_AE = *register_Tk = sub { - my $self = shift; - $Term::ReadLine::registered++ - or Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); - }; - -} +# This package inserts a Tk->fileevent() before the diamond operator. +# The Tk watcher dispatches Tk events until the filehandle returned by +# 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; +}; + +sub register_Tk { + my $self = shift; + $Term::ReadLine::registered++ + or Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); +}; sub tkRunning { $Term::ReadLine::toloop = $_[1] if @_ > 1; $Term::ReadLine::toloop; } -sub get_c { - my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop; - return getc $self->IN; -} +sub PERL_UNICODE_STDIN () { 0x0001 } sub get_line { my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop; - my $in = $self->IN; + my ($in,$out,$str) = @$self; + + if ($Term::ReadLine::toloop) { + $self->register_Tk if not $Term::ReadLine::registered; + $self->Tk_loop; + } + local ($/) = "\n"; - return scalar <$in>; + $str = <$in>; + + 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; } 1; diff --git a/dist/Term-ReadLine/t/AE.t b/dist/Term-ReadLine/t/AE.t deleted file mode 100644 index d0515dc8b5f1..000000000000 --- a/dist/Term-ReadLine/t/AE.t +++ /dev/null @@ -1,33 +0,0 @@ -#!perl - -use Test::More; - -eval "use AnyEvent; 1" or - plan skip_all => "AnyEvent 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'; -} -plan tests => 3; - -# need to delay this so that AE is loaded first. -require Term::ReadLine; -use File::Spec; - -my $t = Term::ReadLine->new('AE'); -ok($t, "Created object"); -is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); -$t->tkRunning(1); - -my $text = 'some text'; -my $T = $text . "\n"; -my $w = AE::timer(0,1,sub { -pass("Event loop called"); -exit 0; -}); - -my $result = $t->readline('Do not press enter>'); -fail("Should not get here."); diff --git a/dist/Term-ReadLine/t/AETk.t b/dist/Term-ReadLine/t/AETk.t deleted file mode 100644 index 9546a8c54907..000000000000 --- a/dist/Term-ReadLine/t/AETk.t +++ /dev/null @@ -1,42 +0,0 @@ -#!perl - -use Test::More; - -eval "use Tk; use AnyEvent; 1" or - plan skip_all => "AnyEvent and/or 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'; - # ensure AE uses Tk. - $ENV{PERL_ANYEVENT_MODEL} = 'Tk'; -} - -eval { - use File::Spec; - my $mw = MainWindow->new(); $mw->withdraw(); - 1; -} or plan skip_all => "Tk can't start. DISPLAY not set?"; - -plan tests => 3; - -# need to delay this so that AE is loaded first. -require Term::ReadLine; -use File::Spec; - -my $t = Term::ReadLine->new('AE/Tk'); -ok($t, "Created object"); -is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); -$t->tkRunning(1); - -my $text = 'some text'; -my $T = $text . "\n"; -my $w = AE::timer(0,1,sub { -pass("Event loop called"); -exit 0; -}); - -my $result = $t->readline('Do not press enter>'); -fail("Should not get here."); diff --git a/dist/Term-ReadLine/t/TkExternal.t b/dist/Term-ReadLine/t/TkExternal.t new file mode 100644 index 000000000000..7c4cf6977393 --- /dev/null +++ b/dist/Term-ReadLine/t/TkExternal.t @@ -0,0 +1,59 @@ +#!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(); +}