home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Perl.pm < prev    next >
Encoding:
Perl POD Document  |  1998-02-19  |  3.7 KB  |  145 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.   unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) {
  63.     local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls
  64.     local $SIG{__WARN__} = sub {}; # With older Perls
  65.     $term->ornaments(1);
  66.   }
  67.   return $term;
  68. }
  69. sub newTTY {
  70.   my ($self, $in, $out) = @_;
  71.   $readline::term_IN   = $self->[0] = $in;
  72.   $readline::term_OUT  = $self->[1] = $out;
  73.   my $sel = select($out);
  74.   $| = 1;                # for DB::OUT
  75.   select($sel);
  76. }
  77. sub ReadLine {'Term::ReadLine::Perl'}
  78. sub MinLine { shift; $readline::minlength = shift }
  79. sub SetHistory {
  80.   shift;
  81.   @readline::rl_History = @_;
  82.   $readline::rl_HistoryIndex = @readline::rl_History;
  83. }
  84. sub GetHistory {
  85.   @readline::rl_History;
  86. }
  87. sub AddHistory {
  88.   shift;
  89.   push @readline::rl_History, @_;
  90.   $readline::rl_HistoryIndex = @readline::rl_History + @_;
  91. }
  92. %features =  (appname => 1, minline => 1, autohistory => 1, getHistory => 1,
  93.           setHistory => 1, addHistory => 1, preput => 1, 
  94.           attribs => 1, 'newTTY' => 1,
  95.           tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
  96.           ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
  97.          );
  98. sub Features { \%features; }
  99. # my %attribs;
  100. tie %attribs, 'Term::ReadLine::Perl::Tie' or die ;
  101. sub Attribs {
  102.   \%attribs;
  103. }
  104. sub DESTROY {}
  105.  
  106. package Term::ReadLine::Perl::AU;
  107.  
  108. sub AUTOLOAD {
  109.   { $AUTOLOAD =~ s/.*:://; }        # preserve match data
  110.   my $name = "readline::rl_$AUTOLOAD";
  111.   die "Cannot do `$AUTOLOAD' in Term::ReadLine::Perl" 
  112.     unless exists $readline::{"rl_$AUTOLOAD"};
  113.   *$AUTOLOAD = sub { shift; &$name };
  114.   goto &$AUTOLOAD;
  115. }
  116.  
  117. package Term::ReadLine::Perl::Tie;
  118.  
  119. sub TIEHASH { bless {} }
  120. sub DESTROY {}
  121.  
  122. sub STORE {
  123.   my ($self, $name) = (shift, shift);
  124.   $ {'readline::rl_' . $name} = shift;
  125. }
  126. sub FETCH {
  127.   my ($self, $name) = (shift, shift);
  128.   $ {'readline::rl_' . $name};
  129. }
  130.  
  131. package Term::ReadLine::Compa;
  132.  
  133. sub get_c {
  134.   my $self = shift;
  135.   getc($self->[0]);
  136. }
  137.  
  138. sub get_line {
  139.   my $self = shift;
  140.   my $fh = $self->[0];
  141.   scalar <$fh>;
  142. }
  143.  
  144. 1;
  145.