summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Term/ReadLine.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Term/ReadLine.pm149
1 files changed, 117 insertions, 32 deletions
diff --git a/Master/tlpkg/tlperl/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
index 0121cdfd065..3770df05529 100644
--- a/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
+++ b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
@@ -114,6 +114,46 @@ additional methods:
makes Tk event loop run when waiting for user input (i.e., during
C<readline> method).
+=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 parameter
+passed in is the return value of the second call back.
+
+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:
+
+ $term->event_loop(sub {
+ my $data = shift;
+ $data->[1] = AE::cv();
+ $data->[1]->recv();
+ }, sub {
+ my $fh = shift;
+ my $data = [];
+ $data->[0] = AE::io($fh, 0, sub { $data->[1]->send() });
+ $data;
+ });
+
+The second call-back is optional if the call back is registered prior to
+the call to $term-E<gt>readline.
+
+Deregistration is done in this case by calling event_loop with C<undef>
+as its parameter:
+
+ $term->event_loop(undef);
+
+This will cause the data array ref to be removed, allowing normal garbage
+collection to clean it up. With AnyEvent, that will cause $data->[0] to
+be cleaned up, and AnyEvent will automatically cancel the watcher at that
+time. If another loop requires more than that to clean up a file watcher,
+that will be up to the caller to handle.
+
=item C<ornaments>
makes the command line stand out by using termcap data. The argument
@@ -150,8 +190,8 @@ be C<o=0> or C<ornaments=0>. The head should be as described above, say
If the variable is not set, or if the head of space-separated list is
empty, the best available package is loaded.
- export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
- export "PERL_RL= o=0" # Use best available ReadLine without ornaments
+ export "PERL_RL=Perl o=0" # Use Perl ReadLine sans ornaments
+ export "PERL_RL= o=0" # Use best available ReadLine sans ornaments
(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
particular used C<Term::ReadLine::*> package).
@@ -176,8 +216,7 @@ sub readline {
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
- and defined &Tk::DoOneEvent;
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop;
#$str = scalar <$in>;
$str = $self->get_line;
utf8::upgrade($str)
@@ -279,16 +318,16 @@ sub Attribs { {} }
my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
sub Features { \%features }
-sub get_line {
- my $self = shift;
- my $in = $self->IN;
- local ($/) = "\n";
- return scalar <$in>;
-}
+#sub get_line {
+# my $self = shift;
+# my $in = $self->IN;
+# local ($/) = "\n";
+# return scalar <$in>;
+#}
package Term::ReadLine; # So late to allow the above code be defined?
-our $VERSION = '1.07';
+our $VERSION = '1.09';
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
@@ -359,42 +398,88 @@ sub ornaments {
package Term::ReadLine::Tk;
-our($count_handle, $count_DoOne, $count_loop);
-$count_handle = $count_DoOne = $count_loop = 0;
+# 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.
-our($giveup);
-sub handle {$giveup = 1; $count_handle++}
+my ($giveup);
-sub Tk_loop {
- # Tk->tkwait('variable',\$giveup); # needs Widget
- $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
- $count_loop++;
- $giveup = 0;
-}
+# maybe in the future the Tk-specific aspects will be removed.
+sub Tk_loop{
+ if (ref $Term::ReadLine::toloop)
+ {
+ $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
+ }
+ else
+ {
+ Tk::DoOneEvent(0) until $giveup;
+ $giveup = 0;
+ }
+};
sub register_Tk {
- my $self = shift;
- $Term::ReadLine::registered++
- or Tk->fileevent($self->IN,'readable',\&handle);
-}
+ my $self = shift;
+ unless ($Term::ReadLine::registered++)
+ {
+ if (ref $Term::ReadLine::toloop)
+ {
+ $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
+ }
+ else
+ {
+ 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 && defined &Tk::DoOneEvent;
- return getc $self->IN;
+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 @_ > 0; # 0 because we shifted off $self.
+ $Term::ReadLine::toloop;
}
+sub PERL_UNICODE_STDIN () { 0x0001 }
+
sub get_line {
my $self = shift;
- $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
- 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;