Newer ReadLine

Finally I could compile GNU ReadLine2.1, so I got some experience with
T::R::Gnu. Unfortunately, debugger could not use any advanced features
of T::R::Gnu since it was accessing the features of T::R::Perl via
backdoors.

I reworked the interface to use object-oriented methods so that it
should not know anything about the particular ReadLine package it uses
(as far as it conforms to some simple interface).

Below is that part of the patch which should go into standard
distribution

Consider it as mildly emergent bug fix, it is -w-safe,

Enjoy,

p5p-msgid: 199703040634.BAA19919@monk.mps.ohio-state.edu

diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm
index 88fc638..0c88a76 100644 (file)
--- a/lib/Term/ReadLine.pm
+++ b/lib/Term/ReadLine.pm
@@ -76,6 +76,12 @@ history. Returns the old value.
 returns an array with two strings that give most appropriate names for
 files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
 
+=item Attribs
+
+returns a reference to a hash which describes internal configuration
+of the package. Names of keys in this hash conform to standard
+conventions with the leading C<rl_> stripped.
+
 =item C<Features>
 
 Returns a reference to a hash with keys being features present in
@@ -86,26 +92,49 @@ C<MinLine> method is not dummy.  C<autohistory> should be present if
 lines are put into history automatically (maybe subject to
 C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
 
+If C<Features> method reports a feature C<attribs> as present, the
+method C<Attribs> is not dummy.
+
 =back
 
+=head1 Additional supported functions
+
 Actually C<Term::ReadLine> can use some other package, that will
 support reacher set of commands.
 
+All these commands are callable via method interface and have names
+which conform to standard conventions with the leading C<rl_> stripped.
+
 =head1 EXPORTS
 
 None
 
+=head1 ENVIRONMENT
+
+The variable C<PERL_RL> governs which ReadLine clone is loaded. If the
+value is false, a dummy interface is used. If the value is true, it
+should be tail of the name of the package to use, such as C<Perl> or
+C<Gnu>. 
+
+If the variable is not set, the best available package is loaded.
+
 =cut
 
 package Term::ReadLine::Stub;
+@ISA = 'Term::ReadLine::Tk';
 
 $DB::emacs = $DB::emacs;       # To peacify -w
 
 sub ReadLine {'Term::ReadLine::Stub'}
 sub readline {
-  my ($in,$out,$str) = @{shift()};
+  my $self = shift;
+  my ($in,$out,$str) = @$self;
   print $out shift; 
-  $str = scalar <$in>;
+  $self->register_Tk 
+     if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+       and defined &Tk::DoOneEvent;
+  #$str = scalar <$in>;
+  $str = $self->get_line;
   # bug in 5.000: chomping empty string creats length -1:
   chomp $str if defined $str;
   $str;
@@ -166,10 +195,27 @@ sub new {
 sub IN { shift->[0] }
 sub OUT { shift->[1] }
 sub MinLine { undef }
-sub Features { {} }
+sub Attribs { {} }
+
+my %features = (tkRunning => 1);
+sub Features { \%features }
 
 package Term::ReadLine;                # So late to allow the above code be defined?
-eval "use Term::ReadLine::Gnu;" or eval "use Term::ReadLine::Perl;";
+
+my $which = $ENV{PERL_RL};
+if ($which) {
+  if ($which =~ /\bgnu\b/i){
+    eval "use Term::ReadLine::Gnu;";
+  } elsif ($which =~ /\bperl\b/i) {
+    eval "use Term::ReadLine::Perl;";
+  } else {
+    eval "use Term::ReadLine::$which;";
+  }
+} elsif (defined $which) {     # Defined but false
+  # Do nothing fancy
+} else {
+  eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
+}
 
 #require FileHandle;
 
@@ -184,6 +230,42 @@ if (defined &Term::ReadLine::Gnu::readline) {
   @ISA = qw(Term::ReadLine::Stub);
 }
 
+package Term::ReadLine::Tk;
+
+$count_handle = $count_DoOne = $count_loop = 0;
+
+sub handle {$giveup = 1; $count_handle++}
+
+sub Tk_loop {
+  # Tk->tkwait('variable',\$giveup);   # needs Widget
+  $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
+  $count_loop++;
+  $giveup = 0;
+}
+
+sub register_Tk {
+  my $self = shift;
+  $Term::ReadLine::registered++ 
+    or Tk->fileevent($self->IN,'readable',\&handle);
+}
+
+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 get_line {
+  my $self = shift;
+  $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+  my $in = $self->IN;
+  return scalar <$in>;
+}
 
 1;
 

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 11d0de7..dbc5531 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -157,7 +157,6 @@ warn (                      # Do not ;-)
       $dumpvar::quoteHighBit,  
       $dumpvar::printUndef,    
       $dumpvar::globPrint,     
-      $readline::Tk_toloop,    
       $dumpvar::usageOnly,
       @ARGS,
       $Carp::CarpLevel,
@@ -189,7 +188,6 @@ $inhibit_exit = $option{PrintRet} = 1;
                 HighBit        => \$dumpvar::quoteHighBit,
                 undefPrint     => \$dumpvar::printUndef,
                 globPrint      => \$dumpvar::globPrint,
-                tkRunning      => \$readline::Tk_toloop,
                 UsageOnly      => \$dumpvar::usageOnly,     
                 frame          => \$frame,
                 AutoTrace      => \$trace,
@@ -212,6 +210,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                  signalLevel   => \&signalLevel,
                  warnLevel     => \&warnLevel,
                  dieLevel      => \&dieLevel,
+                 tkRunning     => \&tkRunning,
                 );
 
 %optionRequire = (
@@ -1357,15 +1356,13 @@ sub setterm {
     } else {
        $term = new Term::ReadLine 'perldb', $IN, $OUT;
 
-       $readline::rl_basic_word_break_characters .= "[:" 
-         if defined $readline::rl_basic_word_break_characters 
-           and index($readline::rl_basic_word_break_characters, ":") == -1;
-       $readline::rl_special_prefixes = 
-         $readline::rl_special_prefixes = '$@&%';
-       $readline::rl_completer_word_break_characters =
-         $readline::rl_completer_word_break_characters . '$@&%';
-       $readline::rl_completion_function = 
-         $readline::rl_completion_function = \&db_complete; 
+       $rl_attribs = $term->Attribs;
+       $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
+         if defined $rl_attribs->{basic_word_break_characters} 
+           and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
+       $rl_attribs->{special_prefixes} = '$@&%';
+       $rl_attribs->{completer_word_break_characters} .= '$@&%';
+       $rl_attribs->{completion_function} = \&db_complete; 
     }
     $LINEINFO = $OUT unless defined $LINEINFO;
     $lineinfo = $console unless defined $lineinfo;
@@ -1524,6 +1521,15 @@ sub ReadLine {
     $rl;
 }
 
+sub tkRunning {
+    if ($ {$term->Features}{tkRunning}) {
+        return $term->tkRunning(@_);
+    } else {
+       print $OUT "tkRunning not supported by current ReadLine package.\n";
+       0;
+    }
+}
+
 sub NonStop {
     if ($term) {
        &warn("Too late to set up NonStop mode!\n") if @_;
@@ -1990,12 +1996,10 @@ sub db_complete {
       $out = "=$val ";
     }
     # Default to value if one completion, to question if many
-    $readline::rl_completer_terminator_character 
-      = $readline::rl_completer_terminator_character
-       = (@out == 1 ? $out : '? ');
+    $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
     return sort @out;
   }
-  return &readline::rl_filename_list($text); # filenames
+  return $term->filename_list($text); # filenames
 }
 
 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }