This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Term::ReadLine: Check $^O before -e
[perl5.git] / dist / Term-ReadLine / lib / Term / ReadLine.pm
CommitLineData
cb31d310
PP
1=head1 NAME
2
7ef5744c
RGS
3Term::ReadLine - Perl interface to various C<readline> packages.
4If no real package is found, substitutes stubs instead of basic functions.
cb31d310
PP
5
6=head1 SYNOPSIS
7
8 use Term::ReadLine;
2b393bf4 9 my $term = Term::ReadLine->new('Simple Perl calc');
7824b127
IM
10 my $prompt = "Enter your arithmetic expression: ";
11 my $OUT = $term->OUT || \*STDOUT;
cb31d310 12 while ( defined ($_ = $term->readline($prompt)) ) {
d49f26d4 13 my $res = eval($_);
cb31d310
PP
14 warn $@ if $@;
15 print $OUT $res, "\n" unless $@;
16 $term->addhistory($_) if /\S/;
17 }
18
c07a80fd
PP
19=head1 DESCRIPTION
20
bbb077f8 21This package is just a front end to some other packages. It's a stub to
22set up a common interface to the various ReadLine implementations found on
23CPAN (under the C<Term::ReadLine::*> namespace).
c07a80fd 24
cb31d310
PP
25=head1 Minimal set of supported functions
26
27All the supported functions should be called as methods, i.e., either as
28
2b393bf4 29 $term = Term::ReadLine->new('name');
cb31d310
PP
30
31or as
32
33 $term->addhistory('row');
34
d49f26d4 35where $term is a return value of Term::ReadLine-E<gt>new().
cb31d310
PP
36
37=over 12
38
39=item C<ReadLine>
40
41returns the actual package that executes the commands. Among possible
42values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
e15d0a48 43C<Term::ReadLine::Stub>.
cb31d310
PP
44
45=item C<new>
46
47returns the handle for subsequent calls to following
48functions. Argument is the name of the application. Optionally can be
49followed by two arguments for C<IN> and C<OUT> filehandles. These
50arguments should be globs.
51
52=item C<readline>
53
54gets an input line, I<possibly> with actual C<readline>
55support. Trailing newline is removed. Returns C<undef> on C<EOF>.
56
57=item C<addhistory>
58
59adds the line to the history of input, from where it can be used if
60the actual C<readline> is present.
61
d49f26d4 62=item C<IN>, C<OUT>
cb31d310
PP
63
64return the filehandles for input and output or C<undef> if C<readline>
65input and output cannot be used for Perl.
66
67=item C<MinLine>
68
69If argument is specified, it is an advice on minimal size of line to
70be included into history. C<undef> means do not include anything into
71history. Returns the old value.
72
73=item C<findConsole>
74
75returns an array with two strings that give most appropriate names for
1fef88e7 76files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
cb31d310 77
a737e074
CS
78=item Attribs
79
80returns a reference to a hash which describes internal configuration
81of the package. Names of keys in this hash conform to standard
82conventions with the leading C<rl_> stripped.
83
cb31d310
PP
84=item C<Features>
85
86Returns a reference to a hash with keys being features present in
87current implementation. Several optional features are used in the
88minimal interface: C<appname> should be present if the first argument
89to C<new> is recognized, and C<minline> should be present if
90C<MinLine> method is not dummy. C<autohistory> should be present if
91lines are put into history automatically (maybe subject to
92C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
93
a737e074
CS
94If C<Features> method reports a feature C<attribs> as present, the
95method C<Attribs> is not dummy.
96
cb31d310
PP
97=back
98
a737e074
CS
99=head1 Additional supported functions
100
cb31d310 101Actually C<Term::ReadLine> can use some other package, that will
bbb077f8 102support a richer set of commands.
cb31d310 103
a737e074
CS
104All these commands are callable via method interface and have names
105which conform to standard conventions with the leading C<rl_> stripped.
106
f36776d9
IZ
107The stub package included with the perl distribution allows some
108additional methods:
109
110=over 12
111
112=item C<tkRunning>
113
de6726c1
RS
114makes Tk event loop run when waiting for user input (i.e., during
115C<readline> method).
fc013e91 116
de6726c1
RS
117=item C<event_loop>
118
119Registers call-backs to wait for user input (i.e., during C<readline>
20a5039a 120method). This supersedes tkRunning.
de6726c1
RS
121
122The first call-back registered is the call back for waiting. It is
123expected that the callback will call the current event loop until
124there is something waiting to get on the input filehandle. The parameter
125passed in is the return value of the second call back.
126
127The second call-back registered is the call back for registration. The
128input filehandle (often STDIN, but not necessarily) will be passed in.
129
130For example, with AnyEvent:
131
0d36d0d1
RS
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 });
de6726c1
RS
142
143The second call-back is optional if the call back is registered prior to
144the call to $term-E<gt>readline.
145
146Deregistration is done in this case by calling event_loop with C<undef>
147as its parameter:
148
149 $term->event_loop(undef);
150
151This will cause the data array ref to be removed, allowing normal garbage
152collection to clean it up. With AnyEvent, that will cause $data->[0] to
153be cleaned up, and AnyEvent will automatically cancel the watcher at that
154time. If another loop requires more than that to clean up a file watcher,
155that will be up to the caller to handle.
f36776d9
IZ
156
157=item C<ornaments>
158
159makes the command line stand out by using termcap data. The argument
160to C<ornaments> should be 0, 1, or a string of a form
161C<"aa,bb,cc,dd">. Four components of this string should be names of
162I<terminal capacities>, first two will be issued to make the prompt
163standout, last two to make the input line standout.
164
165=item C<newTTY>
166
167takes two arguments which are input filehandle and output filehandle.
168Switches to use these filehandles.
169
170=back
171
172One can check whether the currently loaded ReadLine package supports
173these methods by checking for corresponding C<Features>.
7a2e2cd6 174
cb31d310
PP
175=head1 EXPORTS
176
177None
178
a737e074
CS
179=head1 ENVIRONMENT
180
8dcee03e 181The environment variable C<PERL_RL> governs which ReadLine clone is
405ff068
IZ
182loaded. If the value is false, a dummy interface is used. If the value
183is true, it should be tail of the name of the package to use, such as
184C<Perl> or C<Gnu>.
a737e074 185
405ff068
IZ
186As a special case, if the value of this variable is space-separated,
187the tail might be used to disable the ornaments by setting the tail to
188be C<o=0> or C<ornaments=0>. The head should be as described above, say
189
190If the variable is not set, or if the head of space-separated list is
191empty, the best available package is loaded.
192
0d36d0d1
RS
193 export "PERL_RL=Perl o=0" # Use Perl ReadLine sans ornaments
194 export "PERL_RL= o=0" # Use best available ReadLine sans ornaments
405ff068
IZ
195
196(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
197particular used C<Term::ReadLine::*> package).
a737e074 198
cb31d310
PP
199=cut
200
b75c8c73
MS
201use strict;
202
cb31d310 203package Term::ReadLine::Stub;
b75c8c73 204our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
cb31d310 205
d6579db4 206$DB::emacs = $DB::emacs; # To pacify -w
b75c8c73 207our @rl_term_set;
7a2e2cd6 208*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
cb31d310 209
de6726c1 210sub PERL_UNICODE_STDIN () { 0x0001 }
2499d329 211
cb31d310
PP
212sub ReadLine {'Term::ReadLine::Stub'}
213sub readline {
de6726c1
RS
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];
d6579db4 226 # bug in 5.000: chomping empty string creates length -1:
de6726c1
RS
227 chomp $str if defined $str;
228 $str;
cb31d310
PP
229}
230sub addhistory {}
231
232sub findConsole {
233 my $console;
3b2be7b3 234 my $consoleOUT;
cb31d310 235
53e7e3c6 236 if ($^O ne 'MSWin32' and -e "/dev/tty") {
cb31d310 237 $console = "/dev/tty";
53e7e3c6 238 } elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") {
3b2be7b3
JS
239 $console = 'CONIN$';
240 $consoleOUT = 'CONOUT$';
c0788ef2 241 } elsif ($^O eq 'VMS') {
cb31d310 242 $console = "sys\$command";
c0788ef2 243 } elsif ($^O eq 'os2' && !$DB::emacs) {
cb31d310 244 $console = "/dev/con";
c0788ef2
CB
245 } else {
246 $console = undef;
cb31d310
PP
247 }
248
3b2be7b3 249 $consoleOUT = $console unless defined $consoleOUT;
cb31d310 250 $console = "&STDIN" unless defined $console;
d956618a
GA
251 if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) {
252 $console = "&STDIN";
253 undef($consoleOUT);
254 }
cb31d310 255 if (!defined $consoleOUT) {
3b2be7b3 256 $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
cb31d310
PP
257 }
258 ($console,$consoleOUT);
259}
260
261sub new {
262 die "method new called with wrong number of arguments"
263 unless @_==2 or @_==4;
264 #local (*FIN, *FOUT);
405ff068 265 my ($FIN, $FOUT, $ret);
cb31d310 266 if (@_==2) {
4c3ccbe1 267 my($console, $consoleOUT) = $_[0]->findConsole;
cb31d310 268
3b2be7b3
JS
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
cb31d310 276 #OUT->autoflush(1); # Conflicts with debugger?
b75c8c73 277 my $sel = select(FOUT);
cb31d310
PP
278 $| = 1; # for DB::OUT
279 select($sel);
405ff068 280 $ret = bless [\*FIN, \*FOUT];
cb31d310
PP
281 } else { # Filehandles supplied
282 $FIN = $_[2]; $FOUT = $_[3];
283 #OUT->autoflush(1); # Conflicts with debugger?
b75c8c73 284 my $sel = select($FOUT);
cb31d310
PP
285 $| = 1; # for DB::OUT
286 select($sel);
405ff068 287 $ret = bless [$FIN, $FOUT];
cb31d310 288 }
405ff068
IZ
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;
cb31d310 295}
f36776d9
IZ
296
297sub 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
cb31d310
PP
306sub IN { shift->[0] }
307sub OUT { shift->[1] }
308sub MinLine { undef }
a737e074
CS
309sub Attribs { {} }
310
84902520 311my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
a737e074 312sub Features { \%features }
cb31d310 313
b60dd402
DM
314#sub get_line {
315# my $self = shift;
316# my $in = $self->IN;
317# local ($/) = "\n";
318# return scalar <$in>;
319#}
4471601f 320
cb31d310 321package Term::ReadLine; # So late to allow the above code be defined?
a737e074 322
a20d9405 323our $VERSION = '1.14';
b75c8c73 324
405ff068 325my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
a737e074
CS
326if ($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;";
aeeb1390
GS
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'
a737e074
CS
334 } else {
335 eval "use Term::ReadLine::$which;";
336 }
405ff068 337} elsif (defined $which and $which ne '') { # Defined but false
a737e074
CS
338 # Do nothing fancy
339} else {
2f88b466 340 eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::EditLine; 1" or eval "use Term::ReadLine::Perl; 1";
a737e074 341}
cb31d310
PP
342
343#require FileHandle;
344
345# To make possible switch off RL in debugger: (Not needed, work done
346# in debugger).
b75c8c73 347our @ISA;
cb31d310
PP
348if (defined &Term::ReadLine::Gnu::readline) {
349 @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
2f88b466
TM
350} elsif (defined &Term::ReadLine::EditLine::readline) {
351 @ISA = qw(Term::ReadLine::EditLine Term::ReadLine::Stub);
cb31d310
PP
352} elsif (defined &Term::ReadLine::Perl::readline) {
353 @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
e15d0a48
RC
354} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
355 @ISA = "Term::ReadLine::$which";
cb31d310
PP
356} else {
357 @ISA = qw(Term::ReadLine::Stub);
358}
359
7a2e2cd6
PP
360package Term::ReadLine::TermCap;
361
362# Prompt-start, prompt-end, command-line-start, command-line-end
363# -- zero-width beautifies to emit around prompt and the command line.
b75c8c73 364our @rl_term_set = ("","","","");
7a2e2cd6 365# string encoded:
b75c8c73 366our $rl_term_set = ',,,';
7a2e2cd6 367
b75c8c73 368our $terminal;
7a2e2cd6
PP
369sub LoadTermCap {
370 return if defined $terminal;
371
372 require Term::Cap;
373 $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
374}
375
376sub ornaments {
377 shift;
378 return $rl_term_set unless @_;
379 $rl_term_set = shift;
380 $rl_term_set ||= ',,,';
7b8d334a 381 $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
7a2e2cd6
PP
382 my @ts = split /,/, $rl_term_set, 4;
383 eval { LoadTermCap };
405ff068
IZ
384 unless (defined $terminal) {
385 warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
386 $rl_term_set = ',,,';
387 return;
388 }
7a2e2cd6
PP
389 @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
390 return $rl_term_set;
391}
392
393
a737e074
CS
394package Term::ReadLine::Tk;
395
fc013e91
MM
396# This package inserts a Tk->fileevent() before the diamond operator.
397# The Tk watcher dispatches Tk events until the filehandle returned by
398# the$term->IN() accessor becomes ready for reading. It's assumed
399# that the diamond operator will return a line of input immediately at
400# that point.
fc013e91
MM
401
402my ($giveup);
403
404# maybe in the future the Tk-specific aspects will be removed.
405sub Tk_loop{
de6726c1
RS
406 if (ref $Term::ReadLine::toloop)
407 {
408 $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
409 }
410 else
411 {
412 Tk::DoOneEvent(0) until $giveup;
413 $giveup = 0;
414 }
fc013e91
MM
415};
416
417sub register_Tk {
418 my $self = shift;
de6726c1
RS
419 unless ($Term::ReadLine::registered++)
420 {
421 if (ref $Term::ReadLine::toloop)
422 {
423 $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
424 }
425 else
426 {
427 Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
428 }
429 }
fc013e91 430};
a737e074
CS
431
432sub tkRunning {
433 $Term::ReadLine::toloop = $_[1] if @_ > 1;
434 $Term::ReadLine::toloop;
435}
436
de6726c1
RS
437sub event_loop {
438 shift;
439
440 # T::RL::Gnu and T::RL::Perl check that this exists, if not,
441 # it doesn't call the loop. Those modules will need to be
442 # fixed before this can be removed.
443 if (not defined &Tk::DoOneEvent)
444 {
445 *Tk::DoOneEvent = sub {
446 die "what?"; # this shouldn't be called.
447 }
448 }
449
450 # store the callback in toloop, again so that other modules will
451 # recognise it and call us for the loop.
9705c32b 452 $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
de6726c1
RS
453 $Term::ReadLine::toloop;
454}
455
fc013e91 456sub PERL_UNICODE_STDIN () { 0x0001 }
a737e074
CS
457
458sub get_line {
459 my $self = shift;
fc013e91
MM
460 my ($in,$out,$str) = @$self;
461
462 if ($Term::ReadLine::toloop) {
463 $self->register_Tk if not $Term::ReadLine::registered;
464 $self->Tk_loop;
465 }
466
4e83e451 467 local ($/) = "\n";
fc013e91
MM
468 $str = <$in>;
469
470 utf8::upgrade($str)
471 if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
472 utf8::valid($str);
473 print $out $rl_term_set[3];
d6579db4 474 # bug in 5.000: chomping empty string creates length -1:
fc013e91
MM
475 chomp $str if defined $str;
476
477 $str;
a737e074 478}
cb31d310
PP
479
4801;
481