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;