lib/Term/ReadLine.pm

   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 = Term::ReadLine->new('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 = Term::ReadLine->new('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.05';
 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   } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
 315     # it is already in memory to avoid false exception as seen in:
 316     # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
 317   } else {
 318     eval "use Term::ReadLine::$which;";
 319   }
 320 } elsif (defined $which and $which ne '') {     # Defined but false
 321   # Do nothing fancy
 322 } else {
 323   eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
 324 }
 325
 326 #require FileHandle;
 327
 328 # To make possible switch off RL in debugger: (Not needed, work done
 329 # in debugger).
 330 our @ISA;
 331 if (defined &Term::ReadLine::Gnu::readline) {
 332   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 333 } elsif (defined &Term::ReadLine::Perl::readline) {
 334   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
 335 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
 336   @ISA = "Term::ReadLine::$which";
 337 } else {
 338   @ISA = qw(Term::ReadLine::Stub);
 339 }
 340
 341 package Term::ReadLine::TermCap;
 342
 343 # Prompt-start, prompt-end, command-line-start, command-line-end
 344 #     -- zero-width beautifies to emit around prompt and the command line.
 345 our @rl_term_set = ("","","","");
 346 # string encoded:
 347 our $rl_term_set = ',,,';
 348
 349 our $terminal;
 350 sub LoadTermCap {
 351   return if defined $terminal;
 352
 353   require Term::Cap;
 354   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
 355 }
 356
 357 sub ornaments {
 358   shift;
 359   return $rl_term_set unless @_;
 360   $rl_term_set = shift;
 361   $rl_term_set ||= ',,,';
 362   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
 363   my @ts = split /,/, $rl_term_set, 4;
 364   eval { LoadTermCap };
 365   unless (defined $terminal) {
 366     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
 367     $rl_term_set = ',,,';
 368     return;
 369   }
 370   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
 371   return $rl_term_set;
 372 }
 373
 374
 375 package Term::ReadLine::Tk;
 376
 377 our($count_handle, $count_DoOne, $count_loop);
 378 $count_handle = $count_DoOne = $count_loop = 0;
 379
 380 our($giveup);
 381 sub handle {$giveup = 1; $count_handle++}
 382
 383 sub Tk_loop {
 384   # Tk->tkwait('variable',\$giveup);    # needs Widget
 385   $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
 386   $count_loop++;
 387   $giveup = 0;
 388 }
 389
 390 sub register_Tk {
 391   my $self = shift;
 392   $Term::ReadLine::registered++
 393     or Tk->fileevent($self->IN,'readable',\&handle);
 394 }
 395
 396 sub tkRunning {
 397   $Term::ReadLine::toloop = $_[1] if @_ > 1;
 398   $Term::ReadLine::toloop;
 399 }
 400
 401 sub get_c {
 402   my $self = shift;
 403   $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 404   return getc $self->IN;
 405 }
 406
 407 sub get_line {
 408   my $self = shift;
 409   $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 410   my $in = $self->IN;
 411   local ($/) = "\n";
 412   return scalar <$in>;
 413 }
 414
 415 1;
 416