Don't use /dev/tty if it happens to exist on Windows
[perl.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 supercedes 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 peacify -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 creats 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') {
239        $console = 'CONIN$';
240        $consoleOUT = 'CONOUT$';
241     } else {
242         $console = "sys\$command";
243     }
244
245     if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
246         $console = undef;
247     }
248     elsif ($^O eq 'os2') {
249       if ($DB::emacs) {
250         $console = undef;
251       } else {
252         $console = "/dev/con";
253       }
254     }
255
256     $consoleOUT = $console unless defined $consoleOUT;
257     $console = "&STDIN" unless defined $console;
258     if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) {
259       $console = "&STDIN";
260       undef($consoleOUT);
261     }
262     if (!defined $consoleOUT) {
263       $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
264     }
265     ($console,$consoleOUT);
266 }
267
268 sub new {
269   die "method new called with wrong number of arguments" 
270     unless @_==2 or @_==4;
271   #local (*FIN, *FOUT);
272   my ($FIN, $FOUT, $ret);
273   if (@_==2) {
274     my($console, $consoleOUT) = $_[0]->findConsole;
275
276
277     # the Windows CONIN$ needs GENERIC_WRITE mode to allow
278     # a SetConsoleMode() if we end up using Term::ReadKey
279     open FIN, (  $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
280                                                               "<$console";
281     open FOUT,">$consoleOUT";
282
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   } else {                      # Filehandles supplied
289     $FIN = $_[2]; $FOUT = $_[3];
290     #OUT->autoflush(1);         # Conflicts with debugger?
291     my $sel = select($FOUT);
292     $| = 1;                             # for DB::OUT
293     select($sel);
294     $ret = bless [$FIN, $FOUT];
295   }
296   if ($ret->Features->{ornaments} 
297       and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
298     local $Term::ReadLine::termcap_nowarn = 1;
299     $ret->ornaments(1);
300   }
301   return $ret;
302 }
303
304 sub newTTY {
305   my ($self, $in, $out) = @_;
306   $self->[0] = $in;
307   $self->[1] = $out;
308   my $sel = select($out);
309   $| = 1;                               # for DB::OUT
310   select($sel);
311 }
312
313 sub IN { shift->[0] }
314 sub OUT { shift->[1] }
315 sub MinLine { undef }
316 sub Attribs { {} }
317
318 my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
319 sub Features { \%features }
320
321 #sub get_line {
322 #  my $self = shift;
323 #  my $in = $self->IN;
324 #  local ($/) = "\n";
325 #  return scalar <$in>;
326 #}
327
328 package Term::ReadLine;         # So late to allow the above code be defined?
329
330 our $VERSION = '1.10';
331
332 my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
333 if ($which) {
334   if ($which =~ /\bgnu\b/i){
335     eval "use Term::ReadLine::Gnu;";
336   } elsif ($which =~ /\bperl\b/i) {
337     eval "use Term::ReadLine::Perl;";
338   } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
339     # it is already in memory to avoid false exception as seen in:
340     # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
341   } else {
342     eval "use Term::ReadLine::$which;";
343   }
344 } elsif (defined $which and $which ne '') {     # Defined but false
345   # Do nothing fancy
346 } else {
347   eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
348 }
349
350 #require FileHandle;
351
352 # To make possible switch off RL in debugger: (Not needed, work done
353 # in debugger).
354 our @ISA;
355 if (defined &Term::ReadLine::Gnu::readline) {
356   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
357 } elsif (defined &Term::ReadLine::Perl::readline) {
358   @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
359 } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
360   @ISA = "Term::ReadLine::$which";
361 } else {
362   @ISA = qw(Term::ReadLine::Stub);
363 }
364
365 package Term::ReadLine::TermCap;
366
367 # Prompt-start, prompt-end, command-line-start, command-line-end
368 #     -- zero-width beautifies to emit around prompt and the command line.
369 our @rl_term_set = ("","","","");
370 # string encoded:
371 our $rl_term_set = ',,,';
372
373 our $terminal;
374 sub LoadTermCap {
375   return if defined $terminal;
376   
377   require Term::Cap;
378   $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
379 }
380
381 sub ornaments {
382   shift;
383   return $rl_term_set unless @_;
384   $rl_term_set = shift;
385   $rl_term_set ||= ',,,';
386   $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
387   my @ts = split /,/, $rl_term_set, 4;
388   eval { LoadTermCap };
389   unless (defined $terminal) {
390     warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
391     $rl_term_set = ',,,';
392     return;
393   }
394   @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
395   return $rl_term_set;
396 }
397
398
399 package Term::ReadLine::Tk;
400
401 # This package inserts a Tk->fileevent() before the diamond operator.
402 # The Tk watcher dispatches Tk events until the filehandle returned by
403 # the$term->IN() accessor becomes ready for reading.  It's assumed
404 # that the diamond operator will return a line of input immediately at
405 # that point.
406
407 my ($giveup);
408
409 # maybe in the future the Tk-specific aspects will be removed.
410 sub Tk_loop{
411     if (ref $Term::ReadLine::toloop)
412     {
413         $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
414     }
415     else
416     {
417         Tk::DoOneEvent(0) until $giveup;
418         $giveup = 0;
419     }
420 };
421
422 sub register_Tk {
423     my $self = shift;
424     unless ($Term::ReadLine::registered++)
425     {
426         if (ref $Term::ReadLine::toloop)
427         {
428             $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
429         }
430         else
431         {
432             Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
433         }
434     }
435 };
436
437 sub tkRunning {
438   $Term::ReadLine::toloop = $_[1] if @_ > 1;
439   $Term::ReadLine::toloop;
440 }
441
442 sub event_loop {
443     shift;
444
445     # T::RL::Gnu and T::RL::Perl check that this exists, if not,
446     # it doesn't call the loop.  Those modules will need to be
447     # fixed before this can be removed.
448     if (not defined &Tk::DoOneEvent)
449     {
450         *Tk::DoOneEvent = sub {
451             die "what?"; # this shouldn't be called.
452         }
453     }
454
455     # store the callback in toloop, again so that other modules will
456     # recognise it and call us for the loop.
457     $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
458     $Term::ReadLine::toloop;
459 }
460
461 sub PERL_UNICODE_STDIN () { 0x0001 }
462
463 sub get_line {
464   my $self = shift;
465   my ($in,$out,$str) = @$self;
466
467   if ($Term::ReadLine::toloop) {
468     $self->register_Tk if not $Term::ReadLine::registered;
469     $self->Tk_loop;
470   }
471
472   local ($/) = "\n";
473   $str = <$in>;
474
475   utf8::upgrade($str)
476       if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
477          utf8::valid($str);
478   print $out $rl_term_set[3];
479   # bug in 5.000: chomping empty string creats length -1:
480   chomp $str if defined $str;
481
482   $str;
483 }
484
485 1;
486