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 supersedes 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     } elsif ($^O eq 'VMS') {
 242         $console = "sys\$command";
 243     } elsif ($^O eq 'os2' && !$DB::emacs) {
 244         $console = "/dev/con";
 245     } else {
 246         $console = undef;
 247     }
 248
 249     $consoleOUT = $console unless defined $consoleOUT;
 250     $console = "&STDIN" unless defined $console;
 251     if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) {
 252       $console = "&STDIN";
 253       undef($consoleOUT);
 254     }
 255     if (!defined $consoleOUT) {
 256       $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
 257     }
 258     ($console,$consoleOUT);
 259 }
 260
 261 sub new {
 262   die "method new called with wrong number of arguments"
 263     unless @_==2 or @_==4;
 264   #local (*FIN, *FOUT);
 265   my ($FIN, $FOUT, $ret);
 266   if (@_==2) {
 267     my($console, $consoleOUT) = $_[0]->findConsole;
 268
 269
 270     # the Windows CONIN$ needs GENERIC_WRITE mode to allow
 271     # a SetConsoleMode() if we end up using Term::ReadKey
 272     open FIN, (  $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
 273                                                               "<$console";
 274     open FOUT,">$consoleOUT";
 275
 276     #OUT->autoflush(1);         # Conflicts with debugger?
 277     my $sel = select(FOUT);
 278     $| = 1;                             # for DB::OUT
 279     select($sel);
 280     $ret = bless [\*FIN, \*FOUT];
 281   } else {                      # Filehandles supplied
 282     $FIN = $_[2]; $FOUT = $_[3];
 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   }
 289   if ($ret->Features->{ornaments}
 290       and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
 291     local $Term::ReadLine::termcap_nowarn = 1;
 292     $ret->ornaments(1);
 293   }
 294   return $ret;
 295 }
 296
 297 sub newTTY {
 298   my ($self, $in, $out) = @_;
 299   $self->[0] = $in;
 300   $self->[1] = $out;
 301   my $sel = select($out);
 302   $| = 1;                               # for DB::OUT
 303   select($sel);
 304 }
 305
 306 sub IN { shift->[0] }
 307 sub OUT { shift->[1] }
 308 sub MinLine { undef }
 309 sub Attribs { {} }
 310
 311 my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
 312 sub Features { \%features }
 313
 314 #sub get_line {
 315 #  my $self = shift;
 316 #  my $in = $self->IN;
 317 #  local ($/) = "\n";
 318 #  return scalar <$in>;
 319 #}
 320
 321 package Term::ReadLine;         # So late to allow the above code be defined?
 322
 323 our $VERSION = '1.11';
 324
 325 my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
 326 if ($which) {
 327   if ($which =~ /\bgnu\b/i){
 328     eval "use Term::ReadLine::Gnu;";
 329   } elsif ($which =~ /\bperl\b/i) {
 330     eval "use Term::ReadLine::Perl;";
 331   } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
 332     # it is already in memory to avoid false exception as seen in:
 333     # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
 334   } else {
 335     eval "use Term::ReadLine::$which;";
 336   }
 337 } elsif (defined $which and $which ne '') {     # Defined but false
 338   # Do nothing fancy
 339 } else {
 340   eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
 341 }
 342
 343 #require FileHandle;
 344
 345 # To make possible switch off RL in debugger: (Not needed, work done
 346 # in debugger).
 347 our @ISA;
 348 if (defined &Term::ReadLine::Gnu::readline) {
 349   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 350 } elsif (defined &Term::ReadLine::Perl::readline) {
 351   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
 352 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
 353   @ISA = "Term::ReadLine::$which";
 354 } else {
 355   @ISA = qw(Term::ReadLine::Stub);
 356 }
 357
 358 package Term::ReadLine::TermCap;
 359
 360 # Prompt-start, prompt-end, command-line-start, command-line-end
 361 #     -- zero-width beautifies to emit around prompt and the command line.
 362 our @rl_term_set = ("","","","");
 363 # string encoded:
 364 our $rl_term_set = ',,,';
 365
 366 our $terminal;
 367 sub LoadTermCap {
 368   return if defined $terminal;
 369
 370   require Term::Cap;
 371   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
 372 }
 373
 374 sub ornaments {
 375   shift;
 376   return $rl_term_set unless @_;
 377   $rl_term_set = shift;
 378   $rl_term_set ||= ',,,';
 379   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
 380   my @ts = split /,/, $rl_term_set, 4;
 381   eval { LoadTermCap };
 382   unless (defined $terminal) {
 383     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
 384     $rl_term_set = ',,,';
 385     return;
 386   }
 387   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
 388   return $rl_term_set;
 389 }
 390
 391
 392 package Term::ReadLine::Tk;
 393
 394 # This package inserts a Tk->fileevent() before the diamond operator.
 395 # The Tk watcher dispatches Tk events until the filehandle returned by
 396 # the$term->IN() accessor becomes ready for reading.  It's assumed
 397 # that the diamond operator will return a line of input immediately at
 398 # that point.
 399
 400 my ($giveup);
 401
 402 # maybe in the future the Tk-specific aspects will be removed.
 403 sub Tk_loop{
 404     if (ref $Term::ReadLine::toloop)
 405     {
 406         $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
 407     }
 408     else
 409     {
 410         Tk::DoOneEvent(0) until $giveup;
 411         $giveup = 0;
 412     }
 413 };
 414
 415 sub register_Tk {
 416     my $self = shift;
 417     unless ($Term::ReadLine::registered++)
 418     {
 419         if (ref $Term::ReadLine::toloop)
 420         {
 421             $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
 422         }
 423         else
 424         {
 425             Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
 426         }
 427     }
 428 };
 429
 430 sub tkRunning {
 431   $Term::ReadLine::toloop = $_[1] if @_ > 1;
 432   $Term::ReadLine::toloop;
 433 }
 434
 435 sub event_loop {
 436     shift;
 437
 438     # T::RL::Gnu and T::RL::Perl check that this exists, if not,
 439     # it doesn't call the loop.  Those modules will need to be
 440     # fixed before this can be removed.
 441     if (not defined &Tk::DoOneEvent)
 442     {
 443         *Tk::DoOneEvent = sub {
 444             die "what?"; # this shouldn't be called.
 445         }
 446     }
 447
 448     # store the callback in toloop, again so that other modules will
 449     # recognise it and call us for the loop.
 450     $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
 451     $Term::ReadLine::toloop;
 452 }
 453
 454 sub PERL_UNICODE_STDIN () { 0x0001 }
 455
 456 sub get_line {
 457   my $self = shift;
 458   my ($in,$out,$str) = @$self;
 459
 460   if ($Term::ReadLine::toloop) {
 461     $self->register_Tk if not $Term::ReadLine::registered;
 462     $self->Tk_loop;
 463   }
 464
 465   local ($/) = "\n";
 466   $str = <$in>;
 467
 468   utf8::upgrade($str)
 469       if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
 470          utf8::valid($str);
 471   print $out $rl_term_set[3];
 472   # bug in 5.000: chomping empty string creats length -1:
 473   chomp $str if defined $str;
 474
 475   $str;
 476 }
 477
 478 1;
 479