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<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 =cut
 160
 161 use strict;
 162
 163 package Term::ReadLine::Stub;
 164 our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
 165
 166 $DB::emacs = $DB::emacs;        # To peacify -w
 167 our @rl_term_set;
 168 *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
 169
 170 sub PERL_UNICODE_STDIN () { 0x0001 }
 171
 172 sub ReadLine {'Term::ReadLine::Stub'}
 173 sub readline {
 174   my $self = shift;
 175   my ($in,$out,$str) = @$self;
 176   my $prompt = shift;
 177   print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
 178   $self->register_Tk
 179      if not $Term::ReadLine::registered and $Term::ReadLine::toloop
 180         and defined &Tk::DoOneEvent;
 181   #$str = scalar <$in>;
 182   $str = $self->get_line;
 183   utf8::upgrade($str)
 184       if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
 185          utf8::valid($str);
 186   print $out $rl_term_set[3];
 187   # bug in 5.000: chomping empty string creats length -1:
 188   chomp $str if defined $str;
 189   $str;
 190 }
 191 sub addhistory {}
 192
 193 sub findConsole {
 194     my $console;
 195     my $consoleOUT;
 196
 197     if (-e "/dev/tty") {
 198         $console = "/dev/tty";
 199     } elsif (-e "con" or $^O eq 'MSWin32') {
 200        $console = 'CONIN$';
 201        $consoleOUT = 'CONOUT$';
 202     } else {
 203         $console = "sys\$command";
 204     }
 205
 206     if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
 207         $console = undef;
 208     }
 209     elsif ($^O eq 'os2') {
 210       if ($DB::emacs) {
 211         $console = undef;
 212       } else {
 213         $console = "/dev/con";
 214       }
 215     }
 216
 217     $consoleOUT = $console unless defined $consoleOUT;
 218     $console = "&STDIN" unless defined $console;
 219     if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) {
 220       $console = "&STDIN";
 221       undef($consoleOUT);
 222     }
 223     if (!defined $consoleOUT) {
 224       $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
 225     }
 226     ($console,$consoleOUT);
 227 }
 228
 229 sub new {
 230   die "method new called with wrong number of arguments"
 231     unless @_==2 or @_==4;
 232   #local (*FIN, *FOUT);
 233   my ($FIN, $FOUT, $ret);
 234   if (@_==2) {
 235     my($console, $consoleOUT) = $_[0]->findConsole;
 236
 237
 238     # the Windows CONIN$ needs GENERIC_WRITE mode to allow
 239     # a SetConsoleMode() if we end up using Term::ReadKey
 240     open FIN, (  $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
 241                                                               "<$console";
 242     open FOUT,">$consoleOUT";
 243
 244     #OUT->autoflush(1);         # Conflicts with debugger?
 245     my $sel = select(FOUT);
 246     $| = 1;                             # for DB::OUT
 247     select($sel);
 248     $ret = bless [\*FIN, \*FOUT];
 249   } else {                      # Filehandles supplied
 250     $FIN = $_[2]; $FOUT = $_[3];
 251     #OUT->autoflush(1);         # Conflicts with debugger?
 252     my $sel = select($FOUT);
 253     $| = 1;                             # for DB::OUT
 254     select($sel);
 255     $ret = bless [$FIN, $FOUT];
 256   }
 257   if ($ret->Features->{ornaments}
 258       and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
 259     local $Term::ReadLine::termcap_nowarn = 1;
 260     $ret->ornaments(1);
 261   }
 262   return $ret;
 263 }
 264
 265 sub newTTY {
 266   my ($self, $in, $out) = @_;
 267   $self->[0] = $in;
 268   $self->[1] = $out;
 269   my $sel = select($out);
 270   $| = 1;                               # for DB::OUT
 271   select($sel);
 272 }
 273
 274 sub IN { shift->[0] }
 275 sub OUT { shift->[1] }
 276 sub MinLine { undef }
 277 sub Attribs { {} }
 278
 279 my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
 280 sub Features { \%features }
 281
 282 sub get_line {
 283   my $self = shift;
 284   my $in = $self->IN;
 285   local ($/) = "\n";
 286   return scalar <$in>;
 287 }
 288
 289 package Term::ReadLine;         # So late to allow the above code be defined?
 290
 291 our $VERSION = '1.07';
 292
 293 my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
 294 if ($which) {
 295   if ($which =~ /\bgnu\b/i){
 296     eval "use Term::ReadLine::Gnu;";
 297   } elsif ($which =~ /\bperl\b/i) {
 298     eval "use Term::ReadLine::Perl;";
 299   } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
 300     # it is already in memory to avoid false exception as seen in:
 301     # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
 302   } else {
 303     eval "use Term::ReadLine::$which;";
 304   }
 305 } elsif (defined $which and $which ne '') {     # Defined but false
 306   # Do nothing fancy
 307 } else {
 308   eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
 309 }
 310
 311 #require FileHandle;
 312
 313 # To make possible switch off RL in debugger: (Not needed, work done
 314 # in debugger).
 315 our @ISA;
 316 if (defined &Term::ReadLine::Gnu::readline) {
 317   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 318 } elsif (defined &Term::ReadLine::Perl::readline) {
 319   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
 320 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
 321   @ISA = "Term::ReadLine::$which";
 322 } else {
 323   @ISA = qw(Term::ReadLine::Stub);
 324 }
 325
 326 package Term::ReadLine::TermCap;
 327
 328 # Prompt-start, prompt-end, command-line-start, command-line-end
 329 #     -- zero-width beautifies to emit around prompt and the command line.
 330 our @rl_term_set = ("","","","");
 331 # string encoded:
 332 our $rl_term_set = ',,,';
 333
 334 our $terminal;
 335 sub LoadTermCap {
 336   return if defined $terminal;
 337
 338   require Term::Cap;
 339   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
 340 }
 341
 342 sub ornaments {
 343   shift;
 344   return $rl_term_set unless @_;
 345   $rl_term_set = shift;
 346   $rl_term_set ||= ',,,';
 347   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
 348   my @ts = split /,/, $rl_term_set, 4;
 349   eval { LoadTermCap };
 350   unless (defined $terminal) {
 351     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
 352     $rl_term_set = ',,,';
 353     return;
 354   }
 355   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
 356   return $rl_term_set;
 357 }
 358
 359
 360 package Term::ReadLine::Tk;
 361
 362 our($count_handle, $count_DoOne, $count_loop);
 363 $count_handle = $count_DoOne = $count_loop = 0;
 364
 365 our($giveup);
 366 sub handle {$giveup = 1; $count_handle++}
 367
 368 sub Tk_loop {
 369   # Tk->tkwait('variable',\$giveup);    # needs Widget
 370   $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
 371   $count_loop++;
 372   $giveup = 0;
 373 }
 374
 375 sub register_Tk {
 376   my $self = shift;
 377   $Term::ReadLine::registered++
 378     or Tk->fileevent($self->IN,'readable',\&handle);
 379 }
 380
 381 sub tkRunning {
 382   $Term::ReadLine::toloop = $_[1] if @_ > 1;
 383   $Term::ReadLine::toloop;
 384 }
 385
 386 sub get_c {
 387   my $self = shift;
 388   $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 389   return getc $self->IN;
 390 }
 391
 392 sub get_line {
 393   my $self = shift;
 394   $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
 395   my $in = $self->IN;
 396   local ($/) = "\n";
 397   return scalar <$in>;
 398 }
 399
 400 1;
 401