dist/Term-ReadLine/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<event_loop>
 118
 119 Registers call-backs to wait for user input (i.e., during C<readline>
 120 method).  This supercedes tkRunning.
 121
 122 The first call-back registered is the call back for waiting.  It is
 123 expected that the callback will call the current event loop until
 124 there is something waiting to get on the input filehandle.  The parameter
 125 passed in is the return value of the second call back.
 126
 127 The second call-back registered is the call back for registration.  The
 128 input filehandle (often STDIN, but not necessarily) will be passed in.
 129
 130 For example, with AnyEvent:
 131
 132   $term->event_loop(sub {
 133     my $data = shift;
 134     $data->[1] = AE::cv();
 135     $data->[1]->recv();
 136   }, sub {
 137     my $fh = shift;
 138     my $data = [];
 139     $data->[0] = AE::io($fh, 0, sub { $data->[1]->send() });
 140     $data;
 141   });
 142
 143 The second call-back is optional if the call back is registered prior to
 144 the call to $term-E<gt>readline.
 145
 146 Deregistration is done in this case by calling event_loop with C<undef>
 147 as its parameter:
 148
 149     $term->event_loop(undef);
 150
 151 This will cause the data array ref to be removed, allowing normal garbage
 152 collection to clean it up.  With AnyEvent, that will cause $data->[0] to
 153 be cleaned up, and AnyEvent will automatically cancel the watcher at that
 154 time.  If another loop requires more than that to clean up a file watcher,
 155 that will be up to the caller to handle.
 156
 157 =item C<ornaments>
 158
 159 makes the command line stand out by using termcap data.  The argument
 160 to C<ornaments> should be 0, 1, or a string of a form
 161 C<"aa,bb,cc,dd">.  Four components of this string should be names of
 162 I<terminal capacities>, first two will be issued to make the prompt
 163 standout, last two to make the input line standout.
 164
 165 =item C<newTTY>
 166
 167 takes two arguments which are input filehandle and output filehandle.
 168 Switches to use these filehandles.
 169
 170 =back
 171
 172 One can check whether the currently loaded ReadLine package supports
 173 these methods by checking for corresponding C<Features>.
 174
 175 =head1 EXPORTS
 176
 177 None
 178
 179 =head1 ENVIRONMENT
 180
 181 The environment variable C<PERL_RL> governs which ReadLine clone is
 182 loaded. If the value is false, a dummy interface is used. If the value
 183 is true, it should be tail of the name of the package to use, such as
 184 C<Perl> or C<Gnu>.
 185
 186 As a special case, if the value of this variable is space-separated,
 187 the tail might be used to disable the ornaments by setting the tail to
 188 be C<o=0> or C<ornaments=0>.  The head should be as described above, say
 189
 190 If the variable is not set, or if the head of space-separated list is
 191 empty, the best available package is loaded.
 192
 193   export "PERL_RL=Perl o=0" # Use Perl ReadLine sans ornaments
 194   export "PERL_RL= o=0"     # Use best available ReadLine sans ornaments
 195
 196 (Note that processing of C<PERL_RL> for ornaments is in the discretion of the
 197 particular used C<Term::ReadLine::*> package).
 198
 199 =cut
 200
 201 use strict;
 202
 203 package Term::ReadLine::Stub;
 204 our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
 205
 206 $DB::emacs = $DB::emacs;        # To peacify -w
 207 our @rl_term_set;
 208 *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
 209
 210 sub PERL_UNICODE_STDIN () { 0x0001 }
 211
 212 sub ReadLine {'Term::ReadLine::Stub'}
 213 sub readline {
 214   my $self = shift;
 215   my ($in,$out,$str) = @$self;
 216   my $prompt = shift;
 217   print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
 218   $self->register_Tk
 219      if not $Term::ReadLine::registered and $Term::ReadLine::toloop;
 220   #$str = scalar <$in>;
 221   $str = $self->get_line;
 222   utf8::upgrade($str)
 223       if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
 224          utf8::valid($str);
 225   print $out $rl_term_set[3];
 226   # bug in 5.000: chomping empty string creats length -1:
 227   chomp $str if defined $str;
 228   $str;
 229 }
 230 sub addhistory {}
 231
 232 sub findConsole {
 233     my $console;
 234     my $consoleOUT;
 235
 236     if (-e "/dev/tty" and $^O ne 'MSWin32') {
 237         $console = "/dev/tty";
 238     } elsif (-e "con" or $^O eq 'MSWin32' or $^O eq 'msys') {
 239        $console = 'CONIN$';
 240        $consoleOUT = 'CONOUT$';
 241     } else {
 242         $console = "sys\$command";
 243     }
 244
 245     if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
 246         $console = undef;
 247     }
 248     elsif ($^O eq 'os2') {
 249       if ($DB::emacs) {
 250         $console = undef;
 251       } else {
 252         $console = "/dev/con";
 253       }
 254     }
 255
 256     $consoleOUT = $console unless defined $consoleOUT;
 257     $console = "&STDIN" unless defined $console;
 258     if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) {
 259       $console = "&STDIN";
 260       undef($consoleOUT);
 261     }
 262     if (!defined $consoleOUT) {
 263       $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
 264     }
 265     ($console,$consoleOUT);
 266 }
 267
 268 sub new {
 269   die "method new called with wrong number of arguments"
 270     unless @_==2 or @_==4;
 271   #local (*FIN, *FOUT);
 272   my ($FIN, $FOUT, $ret);
 273   if (@_==2) {
 274     my($console, $consoleOUT) = $_[0]->findConsole;
 275
 276
 277     # the Windows CONIN$ needs GENERIC_WRITE mode to allow
 278     # a SetConsoleMode() if we end up using Term::ReadKey
 279     open FIN, (  $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
 280                                                               "<$console";
 281     open FOUT,">$consoleOUT";
 282
 283     #OUT->autoflush(1);         # Conflicts with debugger?
 284     my $sel = select(FOUT);
 285     $| = 1;                             # for DB::OUT
 286     select($sel);
 287     $ret = bless [\*FIN, \*FOUT];
 288   } else {                      # Filehandles supplied
 289     $FIN = $_[2]; $FOUT = $_[3];
 290     #OUT->autoflush(1);         # Conflicts with debugger?
 291     my $sel = select($FOUT);
 292     $| = 1;                             # for DB::OUT
 293     select($sel);
 294     $ret = bless [$FIN, $FOUT];
 295   }
 296   if ($ret->Features->{ornaments}
 297       and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
 298     local $Term::ReadLine::termcap_nowarn = 1;
 299     $ret->ornaments(1);
 300   }
 301   return $ret;
 302 }
 303
 304 sub newTTY {
 305   my ($self, $in, $out) = @_;
 306   $self->[0] = $in;
 307   $self->[1] = $out;
 308   my $sel = select($out);
 309   $| = 1;                               # for DB::OUT
 310   select($sel);
 311 }
 312
 313 sub IN { shift->[0] }
 314 sub OUT { shift->[1] }
 315 sub MinLine { undef }
 316 sub Attribs { {} }
 317
 318 my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
 319 sub Features { \%features }
 320
 321 #sub get_line {
 322 #  my $self = shift;
 323 #  my $in = $self->IN;
 324 #  local ($/) = "\n";
 325 #  return scalar <$in>;
 326 #}
 327
 328 package Term::ReadLine;         # So late to allow the above code be defined?
 329
 330 our $VERSION = '1.10';
 331
 332 my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
 333 if ($which) {
 334   if ($which =~ /\bgnu\b/i){
 335     eval "use Term::ReadLine::Gnu;";
 336   } elsif ($which =~ /\bperl\b/i) {
 337     eval "use Term::ReadLine::Perl;";
 338   } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
 339     # it is already in memory to avoid false exception as seen in:
 340     # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
 341   } else {
 342     eval "use Term::ReadLine::$which;";
 343   }
 344 } elsif (defined $which and $which ne '') {     # Defined but false
 345   # Do nothing fancy
 346 } else {
 347   eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
 348 }
 349
 350 #require FileHandle;
 351
 352 # To make possible switch off RL in debugger: (Not needed, work done
 353 # in debugger).
 354 our @ISA;
 355 if (defined &Term::ReadLine::Gnu::readline) {
 356   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 357 } elsif (defined &Term::ReadLine::Perl::readline) {
 358   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
 359 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
 360   @ISA = "Term::ReadLine::$which";
 361 } else {
 362   @ISA = qw(Term::ReadLine::Stub);
 363 }
 364
 365 package Term::ReadLine::TermCap;
 366
 367 # Prompt-start, prompt-end, command-line-start, command-line-end
 368 #     -- zero-width beautifies to emit around prompt and the command line.
 369 our @rl_term_set = ("","","","");
 370 # string encoded:
 371 our $rl_term_set = ',,,';
 372
 373 our $terminal;
 374 sub LoadTermCap {
 375   return if defined $terminal;
 376
 377   require Term::Cap;
 378   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
 379 }
 380
 381 sub ornaments {
 382   shift;
 383   return $rl_term_set unless @_;
 384   $rl_term_set = shift;
 385   $rl_term_set ||= ',,,';
 386   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
 387   my @ts = split /,/, $rl_term_set, 4;
 388   eval { LoadTermCap };
 389   unless (defined $terminal) {
 390     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
 391     $rl_term_set = ',,,';
 392     return;
 393   }
 394   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
 395   return $rl_term_set;
 396 }
 397
 398
 399 package Term::ReadLine::Tk;
 400
 401 # This package inserts a Tk->fileevent() before the diamond operator.
 402 # The Tk watcher dispatches Tk events until the filehandle returned by
 403 # the$term->IN() accessor becomes ready for reading.  It's assumed
 404 # that the diamond operator will return a line of input immediately at
 405 # that point.
 406
 407 my ($giveup);
 408
 409 # maybe in the future the Tk-specific aspects will be removed.
 410 sub Tk_loop{
 411     if (ref $Term::ReadLine::toloop)
 412     {
 413         $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
 414     }
 415     else
 416     {
 417         Tk::DoOneEvent(0) until $giveup;
 418         $giveup = 0;
 419     }
 420 };
 421
 422 sub register_Tk {
 423     my $self = shift;
 424     unless ($Term::ReadLine::registered++)
 425     {
 426         if (ref $Term::ReadLine::toloop)
 427         {
 428             $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
 429         }
 430         else
 431         {
 432             Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
 433         }
 434     }
 435 };
 436
 437 sub tkRunning {
 438   $Term::ReadLine::toloop = $_[1] if @_ > 1;
 439   $Term::ReadLine::toloop;
 440 }
 441
 442 sub event_loop {
 443     shift;
 444
 445     # T::RL::Gnu and T::RL::Perl check that this exists, if not,
 446     # it doesn't call the loop.  Those modules will need to be
 447     # fixed before this can be removed.
 448     if (not defined &Tk::DoOneEvent)
 449     {
 450         *Tk::DoOneEvent = sub {
 451             die "what?"; # this shouldn't be called.
 452         }
 453     }
 454
 455     # store the callback in toloop, again so that other modules will
 456     # recognise it and call us for the loop.
 457     $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
 458     $Term::ReadLine::toloop;
 459 }
 460
 461 sub PERL_UNICODE_STDIN () { 0x0001 }
 462
 463 sub get_line {
 464   my $self = shift;
 465   my ($in,$out,$str) = @$self;
 466
 467   if ($Term::ReadLine::toloop) {
 468     $self->register_Tk if not $Term::ReadLine::registered;
 469     $self->Tk_loop;
 470   }
 471
 472   local ($/) = "\n";
 473   $str = <$in>;
 474
 475   utf8::upgrade($str)
 476       if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
 477          utf8::valid($str);
 478   print $out $rl_term_set[3];
 479   # bug in 5.000: chomping empty string creats length -1:
 480   chomp $str if defined $str;
 481
 482   $str;
 483 }
 484
 485 1;
 486