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