154 lines
4.0 KiB
Perl
154 lines
4.0 KiB
Perl
package Term::ReadLine::Perl;
|
|
use Carp;
|
|
@ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU);
|
|
#require 'readline.pl';
|
|
|
|
$VERSION = $VERSION = 1.0303;
|
|
|
|
sub readline {
|
|
shift;
|
|
#my $in =
|
|
&readline::readline(@_);
|
|
#$loaded = defined &Term::ReadKey::ReadKey;
|
|
#print STDOUT "\nrl=`$in', loaded = `$loaded'\n";
|
|
#if (ref \$in eq 'GLOB') { # Bug under debugger
|
|
# ($in = "$in") =~ s/^\*(\w+::)+//;
|
|
#}
|
|
#print STDOUT "rl=`$in'\n";
|
|
#$in;
|
|
}
|
|
|
|
#sub addhistory {}
|
|
*addhistory = \&AddHistory;
|
|
|
|
#$term;
|
|
$readline::minlength = 1; # To peacify -w
|
|
$readline::rl_readline_name = undef; # To peacify -w
|
|
$readline::rl_basic_word_break_characters = undef; # To peacify -w
|
|
|
|
sub new {
|
|
if (defined $term) {
|
|
warn "Cannot create second readline interface, falling back to dumb.\n";
|
|
return Term::ReadLine::Stub::new(@_);
|
|
}
|
|
shift; # Package
|
|
if (@_) {
|
|
if ($term) {
|
|
warn "Ignoring name of second readline interface.\n" if defined $term;
|
|
shift;
|
|
} else {
|
|
$readline::rl_readline_name = shift; # Name
|
|
}
|
|
}
|
|
if (!@_) {
|
|
if (!defined $term) {
|
|
($IN,$OUT) = Term::ReadLine->findConsole();
|
|
# Old Term::ReadLine did not have a workaround for a bug in Win devdriver
|
|
$IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON';
|
|
open IN,
|
|
# A workaround for another bug in Win device driver
|
|
(($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN")
|
|
or croak "Cannot open $IN for read";
|
|
open(OUT,">$OUT") || croak "Cannot open $OUT for write";
|
|
$readline::term_IN = \*IN;
|
|
$readline::term_OUT = \*OUT;
|
|
}
|
|
} else {
|
|
if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) {
|
|
croak "Request for a second readline interface with different terminal";
|
|
}
|
|
$readline::term_IN = shift;
|
|
$readline::term_OUT = shift;
|
|
}
|
|
eval {require Term::ReadLine::readline}; die $@ if $@;
|
|
# The following is here since it is mostly used for perl input:
|
|
# $readline::rl_basic_word_break_characters .= '-:+/*,[])}';
|
|
$term = bless [$readline::term_IN,$readline::term_OUT];
|
|
unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) {
|
|
local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls
|
|
local $SIG{__WARN__} = sub {}; # With older Perls
|
|
$term->ornaments(1);
|
|
}
|
|
return $term;
|
|
}
|
|
sub newTTY {
|
|
my ($self, $in, $out) = @_;
|
|
$readline::term_IN = $self->[0] = $in;
|
|
$readline::term_OUT = $self->[1] = $out;
|
|
my $sel = select($out);
|
|
$| = 1; # for DB::OUT
|
|
select($sel);
|
|
}
|
|
sub ReadLine {'Term::ReadLine::Perl'}
|
|
sub MinLine {
|
|
my $old = $readline::minlength;
|
|
$readline::minlength = $_[1] if @_ == 2;
|
|
return $old;
|
|
}
|
|
sub SetHistory {
|
|
shift;
|
|
@readline::rl_History = @_;
|
|
$readline::rl_HistoryIndex = @readline::rl_History;
|
|
}
|
|
sub GetHistory {
|
|
@readline::rl_History;
|
|
}
|
|
sub AddHistory {
|
|
shift;
|
|
push @readline::rl_History, @_;
|
|
$readline::rl_HistoryIndex = @readline::rl_History + @_;
|
|
}
|
|
%features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1,
|
|
setHistory => 1, addHistory => 1, preput => 1,
|
|
attribs => 1, 'newTTY' => 1,
|
|
tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
|
|
ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
|
|
);
|
|
sub Features { \%features; }
|
|
# my %attribs;
|
|
tie %attribs, 'Term::ReadLine::Perl::Tie' or die ;
|
|
sub Attribs {
|
|
\%attribs;
|
|
}
|
|
sub DESTROY {}
|
|
|
|
package Term::ReadLine::Perl::AU;
|
|
|
|
sub AUTOLOAD {
|
|
{ $AUTOLOAD =~ s/.*:://; } # preserve match data
|
|
my $name = "readline::rl_$AUTOLOAD";
|
|
die "Unknown method `$AUTOLOAD' in Term::ReadLine::Perl"
|
|
unless exists $readline::{"rl_$AUTOLOAD"};
|
|
*$AUTOLOAD = sub { shift; &$name };
|
|
goto &$AUTOLOAD;
|
|
}
|
|
|
|
package Term::ReadLine::Perl::Tie;
|
|
|
|
sub TIEHASH { bless {} }
|
|
sub DESTROY {}
|
|
|
|
sub STORE {
|
|
my ($self, $name) = (shift, shift);
|
|
$ {'readline::rl_' . $name} = shift;
|
|
}
|
|
sub FETCH {
|
|
my ($self, $name) = (shift, shift);
|
|
$ {'readline::rl_' . $name};
|
|
}
|
|
|
|
package Term::ReadLine::Compa;
|
|
|
|
sub get_c {
|
|
my $self = shift;
|
|
getc($self->[0]);
|
|
}
|
|
|
|
sub get_line {
|
|
my $self = shift;
|
|
my $fh = $self->[0];
|
|
scalar <$fh>;
|
|
}
|
|
|
|
1;
|