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