Skip to content

Commit

Permalink
Refactor the Tk event loop to allow for other event loops
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
Max Maischein committed Feb 19, 2012
1 parent ac076a5 commit fc013e9
Show file tree
Hide file tree
Showing 4 changed files with 161 additions and 148 deletions.
175 changes: 102 additions & 73 deletions dist/Term-ReadLine/lib/Term/ReadLine.pm
View file
Expand Up @@ -111,9 +111,12 @@ additional methods:
=item C<tkRunning>
makes an event loop run when waiting for user input (i.e., during
C<readline> 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<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<ornaments>
Expand All @@ -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<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
Expand Down Expand Up @@ -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 {}

Expand Down Expand Up @@ -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;
Expand Down
33 changes: 0 additions & 33 deletions dist/Term-ReadLine/t/AE.t
View file

This file was deleted.

42 changes: 0 additions & 42 deletions dist/Term-ReadLine/t/AETk.t
View file

This file was deleted.

59 changes: 59 additions & 0 deletions dist/Term-ReadLine/t/TkExternal.t
View file
@@ -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();
}

0 comments on commit fc013e9

Please sign in to comment.