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