diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Term/ReadLine.pm | 90 | ||||
| -rw-r--r-- | lib/perl5db.pl | 36 |
2 files changed, 106 insertions, 20 deletions
diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 88fc6386c3..0c88a76e41 100644 --- 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 11d0de7bf4..26a3309ca1 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 0.9906; +$VERSION = 0.9907; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -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" } |