home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / Term / ReadLine / Perl.pm next >
Text File  |  1997-08-27  |  4KB  |  139 lines
  1. package Term::ReadLine::Perl;
  2. use Carp;
  3. @ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU);
  4. #require 'readline.pl';
  5.  
  6. $VERSION = $VERSION = 0.99;
  7.  
  8. sub 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.  
  29. sub 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.       open(IN,"<$IN") || croak "Cannot open $IN for read";
  47.       open(OUT,">$OUT") || croak "Cannot open $OUT for write";
  48.       $readline::term_IN = \*IN;
  49.       $readline::term_OUT = \*OUT;
  50.     }
  51.   } else {
  52.     if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) {
  53.       croak "Request for a second readline interface with different terminal";
  54.     }
  55.     $readline::term_IN = shift;
  56.     $readline::term_OUT = shift;    
  57.   }
  58.   eval {require Term::ReadLine::readline}; die $@ if $@;
  59.   # The following is here since it is mostly used for perl input:
  60.   # $readline::rl_basic_word_break_characters .= '-:+/*,[])}';
  61.   $term = bless [$readline::term_IN,$readline::term_OUT];
  62. }
  63. sub newTTY {
  64.   my ($self, $in, $out) = @_;
  65.   $readline::term_IN   = $self->[0] = $in;
  66.   $readline::term_OUT  = $self->[1] = $out;
  67.   my $sel = select($out);
  68.   $| = 1;                # for DB::OUT
  69.   select($sel);
  70. }
  71. sub ReadLine {'Term::ReadLine::Perl'}
  72. sub MinLine { shift; $readline::minlength = shift }
  73. sub SetHistory {
  74.   shift;
  75.   @readline::rl_History = @_;
  76.   $readline::rl_HistoryIndex = @readline::rl_History;
  77. }
  78. sub GetHistory {
  79.   @readline::rl_History;
  80. }
  81. sub AddHistory {
  82.   shift;
  83.   push @readline::rl_History, @_;
  84.   $readline::rl_HistoryIndex = @readline::rl_History + @_;
  85. }
  86. %features =  (appname => 1, minline => 1, autohistory => 1, getHistory => 1,
  87.           setHistory => 1, addHistory => 1, preput => 1, 
  88.           attribs => 1, 'newTTY' => 1,
  89.           tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
  90.           ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
  91.          );
  92. sub Features { \%features; }
  93. # my %attribs;
  94. tie %attribs, 'Term::ReadLine::Perl::Tie' or die ;
  95. sub Attribs {
  96.   \%attribs;
  97. }
  98. sub DESTROY {}
  99.  
  100. package Term::ReadLine::Perl::AU;
  101.  
  102. sub AUTOLOAD {
  103.   { $AUTOLOAD =~ s/.*:://; }        # preserve match data
  104.   my $name = "readline::rl_$AUTOLOAD";
  105.   die "Cannot do `$AUTOLOAD' in Term::ReadLine::Perl" 
  106.     unless exists $readline::{"rl_$AUTOLOAD"};
  107.   *$AUTOLOAD = sub { shift; &$name };
  108.   goto &$AUTOLOAD;
  109. }
  110.  
  111. package Term::ReadLine::Perl::Tie;
  112.  
  113. sub TIEHASH { bless {} }
  114. sub DESTROY {}
  115.  
  116. sub STORE {
  117.   my ($self, $name) = (shift, shift);
  118.   $ {'readline::rl_' . $name} = shift;
  119. }
  120. sub FETCH {
  121.   my ($self, $name) = (shift, shift);
  122.   $ {'readline::rl_' . $name};
  123. }
  124.  
  125. package Term::ReadLine::Compa;
  126.  
  127. sub get_c {
  128.   my $self = shift;
  129.   getc($self->[0]);
  130. }
  131.  
  132. sub get_line {
  133.   my $self = shift;
  134.   my $fh = $self->[0];
  135.   scalar <$fh>;
  136. }
  137.  
  138. 1;
  139.