Initial Commit

database/perl/vendor/lib/Term/ReadLine/Perl.pm

@@ -0,0 +1,153 @@
+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;