This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
80a0d4bac88dead19fc4f062b254e8a91ba203da
[perl5.git] / 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 pacify -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 creates 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.14';
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::EditLine; 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::EditLine::readline) {
351   @ISA = qw(Term::ReadLine::EditLine Term::ReadLine::Stub);
352 } elsif (defined &Term::ReadLine::Perl::readline) {
353   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
354 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
355   @ISA = "Term::ReadLine::$which";
356 } else {
357   @ISA = qw(Term::ReadLine::Stub);
358 }
359
360 package 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.
364 our @rl_term_set = ("","","","");
365 # string encoded:
366 our $rl_term_set = ',,,';
367
368 our $terminal;
369 sub LoadTermCap {
370   return if defined $terminal;
371   
372   require Term::Cap;
373   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
374 }
375
376 sub ornaments {
377   shift;
378   return $rl_term_set unless @_;
379   $rl_term_set = shift;
380   $rl_term_set ||= ',,,';
381   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
382   my @ts = split /,/, $rl_term_set, 4;
383   eval { LoadTermCap };
384   unless (defined $terminal) {
385     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
386     $rl_term_set = ',,,';
387     return;
388   }
389   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
390   return $rl_term_set;
391 }
392
393
394 package Term::ReadLine::Tk;
395
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.
401
402 my ($giveup);
403
404 # maybe in the future the Tk-specific aspects will be removed.
405 sub Tk_loop{
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     }
415 };
416
417 sub register_Tk {
418     my $self = shift;
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     }
430 };
431
432 sub tkRunning {
433   $Term::ReadLine::toloop = $_[1] if @_ > 1;
434   $Term::ReadLine::toloop;
435 }
436
437 sub 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.
452     $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
453     $Term::ReadLine::toloop;
454 }
455
456 sub PERL_UNICODE_STDIN () { 0x0001 }
457
458 sub get_line {
459   my $self = shift;
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
467   local ($/) = "\n";
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];
474   # bug in 5.000: chomping empty string creates length -1:
475   chomp $str if defined $str;
476
477   $str;
478 }
479
480 1;
481