[Summary view] [Print] [Text view]

   1  =head1 NAME
   2  
   3  Term::ReadLine - Perl interface to various C<readline> packages.
   4  If no real package is found, substitutes stubs instead of basic functions.
   5  
   6  =head1 SYNOPSIS
   7  
   8    use Term::ReadLine;
   9    my $term = new Term::ReadLine 'Simple Perl calc';
  10    my $prompt = "Enter your arithmetic expression: ";
  11    my $OUT = $term->OUT || \*STDOUT;
  12    while ( defined ($_ = $term->readline($prompt)) ) {
  13      my $res = eval($_);
  14      warn $@ if $@;
  15      print $OUT $res, "\n" unless $@;
  16      $term->addhistory($_) if /\S/;
  17    }
  18  
  19  =head1 DESCRIPTION
  20  
  21  This package is just a front end to some other packages. It's a stub to
  22  set up a common interface to the various ReadLine implementations found on
  23  CPAN (under the C<Term::ReadLine::*> namespace).
  24  
  25  =head1 Minimal set of supported functions
  26  
  27  All the supported functions should be called as methods, i.e., either as 
  28  
  29    $term = new Term::ReadLine 'name';
  30  
  31  or as 
  32  
  33    $term->addhistory('row');
  34  
  35  where $term is a return value of Term::ReadLine-E<gt>new().
  36  
  37  =over 12
  38  
  39  =item C<ReadLine>
  40  
  41  returns the actual package that executes the commands. Among possible
  42  values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
  43  C<Term::ReadLine::Stub>.
  44  
  45  =item C<new>
  46  
  47  returns the handle for subsequent calls to following
  48  functions. Argument is the name of the application. Optionally can be
  49  followed by two arguments for C<IN> and C<OUT> filehandles. These
  50  arguments should be globs.
  51  
  52  =item C<readline>
  53  
  54  gets an input line, I<possibly> with actual C<readline>
  55  support. Trailing newline is removed. Returns C<undef> on C<EOF>.
  56  
  57  =item C<addhistory>
  58  
  59  adds the line to the history of input, from where it can be used if
  60  the actual C<readline> is present.
  61  
  62  =item C<IN>, C<OUT>
  63  
  64  return the filehandles for input and output or C<undef> if C<readline>
  65  input and output cannot be used for Perl.
  66  
  67  =item C<MinLine>
  68  
  69  If argument is specified, it is an advice on minimal size of line to
  70  be included into history.  C<undef> means do not include anything into
  71  history. Returns the old value.
  72  
  73  =item C<findConsole>
  74  
  75  returns an array with two strings that give most appropriate names for
  76  files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
  77  
  78  =item Attribs
  79  
  80  returns a reference to a hash which describes internal configuration
  81  of the package. Names of keys in this hash conform to standard
  82  conventions with the leading C<rl_> stripped.
  83  
  84  =item C<Features>
  85  
  86  Returns a reference to a hash with keys being features present in
  87  current implementation. Several optional features are used in the
  88  minimal interface: C<appname> should be present if the first argument
  89  to C<new> is recognized, and C<minline> should be present if
  90  C<MinLine> method is not dummy.  C<autohistory> should be present if
  91  lines are put into history automatically (maybe subject to
  92  C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
  93  
  94  If C<Features> method reports a feature C<attribs> as present, the
  95  method C<Attribs> is not dummy.
  96  
  97  =back
  98  
  99  =head1 Additional supported functions
 100  
 101  Actually C<Term::ReadLine> can use some other package, that will
 102  support a richer set of commands.
 103  
 104  All these commands are callable via method interface and have names
 105  which conform to standard conventions with the leading C<rl_> stripped.
 106  
 107  The stub package included with the perl distribution allows some
 108  additional methods: 
 109  
 110  =over 12
 111  
 112  =item C<tkRunning>
 113  
 114  makes Tk event loop run when waiting for user input (i.e., during
 115  C<readline> method).
 116  
 117  =item C<ornaments>
 118  
 119  makes the command line stand out by using termcap data.  The argument
 120  to C<ornaments> should be 0, 1, or a string of a form
 121  C<"aa,bb,cc,dd">.  Four components of this string should be names of
 122  I<terminal capacities>, first two will be issued to make the prompt
 123  standout, last two to make the input line standout.
 124  
 125  =item C<newTTY>
 126  
 127  takes two arguments which are input filehandle and output filehandle.
 128  Switches to use these filehandles.
 129  
 130  =back
 131  
 132  One can check whether the currently loaded ReadLine package supports
 133  these methods by checking for corresponding C<Features>.
 134  
 135  =head1 EXPORTS
 136  
 137  None
 138  
 139  =head1 ENVIRONMENT
 140  
 141  The environment variable C<PERL_RL> governs which ReadLine clone is
 142  loaded. If the value is false, a dummy interface is used. If the value
 143  is true, it should be tail of the name of the package to use, such as
 144  C<Perl> or C<Gnu>.  
 145  
 146  As a special case, if the value of this variable is space-separated,
 147  the tail might be used to disable the ornaments by setting the tail to
 148  be C<o=0> or C<ornaments=0>.  The head should be as described above, say
 149  
 150  If the variable is not set, or if the head of space-separated list is
 151  empty, the best available package is loaded.
 152  
 153    export "PERL_RL=Perl o=0"    # Use Perl ReadLine without ornaments
 154    export "PERL_RL= o=0"        # Use best available ReadLine without ornaments
 155  
 156  (Note that processing of C<PERL_RL> for ornaments is in the discretion of the 
 157  particular used C<Term::ReadLine::*> package).
 158  
 159  =head1 CAVEATS
 160  
 161  It seems that using Term::ReadLine from Emacs minibuffer doesn't work
 162  quite right and one will get an error message like
 163  
 164      Cannot open /dev/tty for read at ...
 165  
 166  One possible workaround for this is to explicitly open /dev/tty like this
 167  
 168      open (FH, "/dev/tty" )
 169        or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
 170      die $@ if $@;
 171      close (FH);
 172  
 173  or you can try using the 4-argument form of Term::ReadLine->new().
 174  
 175  =cut
 176  
 177  use strict;
 178  
 179  package Term::ReadLine::Stub;
 180  our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
 181  
 182  $DB::emacs = $DB::emacs;    # To peacify -w
 183  our @rl_term_set;
 184  *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
 185  
 186  sub PERL_UNICODE_STDIN () { 0x0001 }
 187  
 188  sub ReadLine {'Term::ReadLine::Stub'}
 189  sub readline {
 190    my $self = shift;
 191    my ($in,$out,$str) = @$self;
 192    my $prompt = shift;
 193    print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; 
 194    $self->register_Tk 
 195       if not $Term::ReadLine::registered and $Term::ReadLine::toloop
 196      and defined &Tk::DoOneEvent;
 197    #$str = scalar <$in>;
 198    $str = $self->get_line;
 199    $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
 200    utf8::upgrade($str)
 201        if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
 202           utf8::valid($str);
 203    print $out $rl_term_set[3]; 
 204    # bug in 5.000: chomping empty string creats length -1:
 205    chomp $str if defined $str;
 206    $str;
 207  }
 208  sub addhistory {}
 209  
 210  sub findConsole {
 211      my $console;
 212      my $consoleOUT;
 213  
 214      if ($^O eq 'MacOS') {
 215          $console = "Dev:Console";
 216      } elsif (-e "/dev/tty") {
 217      $console = "/dev/tty";
 218      } elsif (-e "con" or $^O eq 'MSWin32') {
 219         $console = 'CONIN$';
 220         $consoleOUT = 'CONOUT$';
 221      } else {
 222      $console = "sys\$command";
 223      }
 224  
 225      if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
 226      $console = undef;
 227      }
 228      elsif ($^O eq 'os2') {
 229        if ($DB::emacs) {
 230      $console = undef;
 231        } else {
 232      $console = "/dev/con";
 233        }
 234      }
 235  
 236      $consoleOUT = $console unless defined $consoleOUT;
 237      $console = "&STDIN" unless defined $console;
 238      if (!defined $consoleOUT) {
 239        $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
 240      }
 241      ($console,$consoleOUT);
 242  }
 243  
 244  sub new {
 245    die "method new called with wrong number of arguments" 
 246      unless @_==2 or @_==4;
 247    #local (*FIN, *FOUT);
 248    my ($FIN, $FOUT, $ret);
 249    if (@_==2) {
 250      my($console, $consoleOUT) = $_[0]->findConsole;
 251  
 252  
 253      # the Windows CONIN$ needs GENERIC_WRITE mode to allow
 254      # a SetConsoleMode() if we end up using Term::ReadKey
 255      open FIN, (  $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
 256                                                                "<$console";
 257      open FOUT,">$consoleOUT";
 258  
 259      #OUT->autoflush(1);        # Conflicts with debugger?
 260      my $sel = select(FOUT);
 261      $| = 1;                # for DB::OUT
 262      select($sel);
 263      $ret = bless [\*FIN, \*FOUT];
 264    } else {            # Filehandles supplied
 265      $FIN = $_[2]; $FOUT = $_[3];
 266      #OUT->autoflush(1);        # Conflicts with debugger?
 267      my $sel = select($FOUT);
 268      $| = 1;                # for DB::OUT
 269      select($sel);
 270      $ret = bless [$FIN, $FOUT];
 271    }
 272    if ($ret->Features->{ornaments} 
 273        and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
 274      local $Term::ReadLine::termcap_nowarn = 1;
 275      $ret->ornaments(1);
 276    }
 277    return $ret;
 278  }
 279  
 280  sub newTTY {
 281    my ($self, $in, $out) = @_;
 282    $self->[0] = $in;
 283    $self->[1] = $out;
 284    my $sel = select($out);
 285    $| = 1;                # for DB::OUT
 286    select($sel);
 287  }
 288  
 289  sub IN { shift->[0] }
 290  sub OUT { shift->[1] }
 291  sub MinLine { undef }
 292  sub Attribs { {} }
 293  
 294  my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
 295  sub Features { \%features }
 296  
 297  sub get_line {
 298    my $self = shift;
 299    my $in = $self->IN;
 300    local ($/) = "\n";
 301    return scalar <$in>;
 302  }
 303  
 304  package Term::ReadLine;        # So late to allow the above code be defined?
 305  
 306  our $VERSION = '1.03';
 307  
 308  my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
 309  if ($which) {
 310    if ($which =~ /\bgnu\b/i){
 311      eval "use Term::ReadLine::Gnu;";
 312    } elsif ($which =~ /\bperl\b/i) {
 313      eval "use Term::ReadLine::Perl;";
 314    } else {
 315      eval "use Term::ReadLine::$which;";
 316    }
 317  } elsif (defined $which and $which ne '') {    # Defined but false
 318    # Do nothing fancy
 319  } else {
 320    eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
 321  }
 322  
 323  #require FileHandle;
 324  
 325  # To make possible switch off RL in debugger: (Not needed, work done
 326  # in debugger).
 327  our @ISA;
 328  if (defined &Term::ReadLine::Gnu::readline) {
 329    @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 330  } elsif (defined &Term::ReadLine::Perl::readline) {
 331    @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
 332  } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
 333    @ISA = "Term::ReadLine::$which";
 334  } else {
 335    @ISA = qw(Term::ReadLine::Stub);
 336  }
 337  
 338  package Term::ReadLine::TermCap;
 339  
 340  # Prompt-start, prompt-end, command-line-start, command-line-end
 341  #     -- zero-width beautifies to emit around prompt and the command line.
 342  our @rl_term_set = ("","","","");
 343  # string encoded:
 344  our $rl_term_set = ',,,';
 345  
 346  our $terminal;
 347  sub LoadTermCap {
 348    return if defined $terminal;
 349    
 350    require Term::Cap;
 351    $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
 352  }
 353  
 354  sub ornaments {
 355    shift;
 356    return $rl_term_set unless @_;
 357    $rl_term_set = shift;
 358    $rl_term_set ||= ',,,';
 359    $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
 360    my @ts = split /,/, $rl_term_set, 4;
 361    eval { LoadTermCap };
 362    unless (defined $terminal) {
 363      warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
 364      $rl_term_set = ',,,';
 365      return;
 366    }
 367    @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
 368    return $rl_term_set;
 369  }
 370  
 371  
 372  package Term::ReadLine::Tk;
 373  
 374  our($count_handle, $count_DoOne, $count_loop);
 375  $count_handle = $count_DoOne = $count_loop = 0;
 376  
 377  our($giveup);
 378  sub handle {$giveup = 1; $count_handle++}
 379  
 380  sub Tk_loop {
 381    # Tk->tkwait('variable',\$giveup);    # needs Widget
 382    $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
 383    $count_loop++;
 384    $giveup = 0;
 385  }
 386  
 387  sub register_Tk {
 388    my $self = shift;
 389    $Term::ReadLine::registered++ 
 390      or Tk->fileevent($self->IN,'readable',\&handle);
 391  }
 392  
 393  sub tkRunning {
 394    $Term::ReadLine::toloop = $_[1] if @_ > 1;
 395    $Term::ReadLine::toloop;
 396  }
 397  
 398  sub get_c {
 399    my $self = shift;
 400    $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 401    return getc $self->IN;
 402  }
 403  
 404  sub get_line {
 405    my $self = shift;
 406    $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 407    my $in = $self->IN;
 408    local ($/) = "\n";
 409    return scalar <$in>;
 410  }
 411  
 412  1;
 413