1package Term::ReadLine::Perl; 2use Carp; 3@ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU); 4#require 'readline.pl'; 5 6$VERSION = $VERSION = 1.0303; 7 8sub readline { 9 shift; 10 #my $in = 11 &readline::readline(@_); 12 #$loaded = defined &Term::ReadKey::ReadKey; 13 #print STDOUT "\nrl=`$in', loaded = `$loaded'\n"; 14 #if (ref \$in eq 'GLOB') { # Bug under debugger 15 # ($in = "$in") =~ s/^\*(\w+::)+//; 16 #} 17 #print STDOUT "rl=`$in'\n"; 18 #$in; 19} 20 21#sub addhistory {} 22*addhistory = \&AddHistory; 23 24#$term; 25$readline::minlength = 1; # To peacify -w 26$readline::rl_readline_name = undef; # To peacify -w 27$readline::rl_basic_word_break_characters = undef; # To peacify -w 28 29sub new { 30 if (defined $term) { 31 warn "Cannot create second readline interface, falling back to dumb.\n"; 32 return Term::ReadLine::Stub::new(@_); 33 } 34 shift; # Package 35 if (@_) { 36 if ($term) { 37 warn "Ignoring name of second readline interface.\n" if defined $term; 38 shift; 39 } else { 40 $readline::rl_readline_name = shift; # Name 41 } 42 } 43 if (!@_) { 44 if (!defined $term) { 45 ($IN,$OUT) = Term::ReadLine->findConsole(); 46 # Old Term::ReadLine did not have a workaround for a bug in Win devdriver 47 $IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON'; 48 open IN, 49 # A workaround for another bug in Win device driver 50 (($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN") 51 or croak "Cannot open $IN for read"; 52 open(OUT,">$OUT") || croak "Cannot open $OUT for write"; 53 $readline::term_IN = \*IN; 54 $readline::term_OUT = \*OUT; 55 } 56 } else { 57 if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) { 58 croak "Request for a second readline interface with different terminal"; 59 } 60 $readline::term_IN = shift; 61 $readline::term_OUT = shift; 62 } 63 eval {require Term::ReadLine::readline}; die $@ if $@; 64 # The following is here since it is mostly used for perl input: 65 # $readline::rl_basic_word_break_characters .= '-:+/*,[])}'; 66 $term = bless [$readline::term_IN,$readline::term_OUT]; 67 unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) { 68 local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls 69 local $SIG{__WARN__} = sub {}; # With older Perls 70 $term->ornaments(1); 71 } 72 return $term; 73} 74sub newTTY { 75 my ($self, $in, $out) = @_; 76 $readline::term_IN = $self->[0] = $in; 77 $readline::term_OUT = $self->[1] = $out; 78 my $sel = select($out); 79 $| = 1; # for DB::OUT 80 select($sel); 81} 82sub ReadLine {'Term::ReadLine::Perl'} 83sub MinLine { 84 my $old = $readline::minlength; 85 $readline::minlength = $_[1] if @_ == 2; 86 return $old; 87} 88sub SetHistory { 89 shift; 90 @readline::rl_History = @_; 91 $readline::rl_HistoryIndex = @readline::rl_History; 92} 93sub GetHistory { 94 @readline::rl_History; 95} 96sub AddHistory { 97 shift; 98 push @readline::rl_History, @_; 99 $readline::rl_HistoryIndex = @readline::rl_History + @_; 100} 101%features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1, 102 setHistory => 1, addHistory => 1, preput => 1, 103 attribs => 1, 'newTTY' => 1, 104 tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'}, 105 ornaments => Term::ReadLine::Stub->Features->{'ornaments'}, 106 ); 107sub Features { \%features; } 108# my %attribs; 109tie %attribs, 'Term::ReadLine::Perl::Tie' or die ; 110sub Attribs { 111 \%attribs; 112} 113sub DESTROY {} 114 115package Term::ReadLine::Perl::AU; 116 117sub AUTOLOAD { 118 { $AUTOLOAD =~ s/.*:://; } # preserve match data 119 my $name = "readline::rl_$AUTOLOAD"; 120 die "Unknown method `$AUTOLOAD' in Term::ReadLine::Perl" 121 unless exists $readline::{"rl_$AUTOLOAD"}; 122 *$AUTOLOAD = sub { shift; &$name }; 123 goto &$AUTOLOAD; 124} 125 126package Term::ReadLine::Perl::Tie; 127 128sub TIEHASH { bless {} } 129sub DESTROY {} 130 131sub STORE { 132 my ($self, $name) = (shift, shift); 133 $ {'readline::rl_' . $name} = shift; 134} 135sub FETCH { 136 my ($self, $name) = (shift, shift); 137 $ {'readline::rl_' . $name}; 138} 139 140package Term::ReadLine::Compa; 141 142sub get_c { 143 my $self = shift; 144 getc($self->[0]); 145} 146 147sub get_line { 148 my $self = shift; 149 my $fh = $self->[0]; 150 scalar <$fh>; 151} 152 1531; 154