Commit | Line | Data |
cb31d310 |
1 | =head1 NAME |
2 | |
7ef5744c |
3 | Term::ReadLine - Perl interface to various C<readline> packages. |
4 | If no real package is found, substitutes stubs instead of basic functions. |
cb31d310 |
5 | |
6 | =head1 SYNOPSIS |
7 | |
8 | use Term::ReadLine; |
7824b127 |
9 | my $term = new Term::ReadLine 'Simple Perl calc'; |
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 |
14 | warn $@ if $@; |
15 | print $OUT $res, "\n" unless $@; |
16 | $term->addhistory($_) if /\S/; |
17 | } |
18 | |
c07a80fd |
19 | =head1 DESCRIPTION |
20 | |
bbb077f8 |
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). |
c07a80fd |
24 | |
cb31d310 |
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 = new Term::ReadLine 'name'; |
30 | |
31 | or as |
32 | |
33 | $term->addhistory('row'); |
34 | |
d49f26d4 |
35 | where $term is a return value of Term::ReadLine-E<gt>new(). |
cb31d310 |
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>, |
e15d0a48 |
43 | C<Term::ReadLine::Stub>. |
cb31d310 |
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 | |
d49f26d4 |
62 | =item C<IN>, C<OUT> |
cb31d310 |
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 |
1fef88e7 |
76 | files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">. |
cb31d310 |
77 | |
a737e074 |
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 | |
cb31d310 |
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 | |
a737e074 |
94 | If C<Features> method reports a feature C<attribs> as present, the |
95 | method C<Attribs> is not dummy. |
96 | |
cb31d310 |
97 | =back |
98 | |
a737e074 |
99 | =head1 Additional supported functions |
100 | |
cb31d310 |
101 | Actually C<Term::ReadLine> can use some other package, that will |
bbb077f8 |
102 | support a richer set of commands. |
cb31d310 |
103 | |
a737e074 |
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 | |
f36776d9 |
107 | The stub package included with the perl distribution allows some |
108 | additional methods: |
109 | |
110 | =over 12 |
111 | |
112 | =item C<tkRunning> |
113 | |
7a2e2cd6 |
114 | makes Tk event loop run when waiting for user input (i.e., during |
f36776d9 |
115 | C<readline> method). |
116 | |
117 | =item C<ornaments> |
118 | |
119 | makes the command line stand out by using termcap data. The argument |
120 | to C<ornaments> should be 0, 1, or a string of a form |
121 | C<"aa,bb,cc,dd">. Four components of this string should be names of |
122 | I<terminal capacities>, first two will be issued to make the prompt |
123 | standout, last two to make the input line standout. |
124 | |
125 | =item C<newTTY> |
126 | |
127 | takes two arguments which are input filehandle and output filehandle. |
128 | Switches to use these filehandles. |
129 | |
130 | =back |
131 | |
132 | One can check whether the currently loaded ReadLine package supports |
133 | these methods by checking for corresponding C<Features>. |
7a2e2cd6 |
134 | |
cb31d310 |
135 | =head1 EXPORTS |
136 | |
137 | None |
138 | |
a737e074 |
139 | =head1 ENVIRONMENT |
140 | |
8dcee03e |
141 | The environment variable C<PERL_RL> governs which ReadLine clone is |
405ff068 |
142 | loaded. If the value is false, a dummy interface is used. If the value |
143 | is true, it should be tail of the name of the package to use, such as |
144 | C<Perl> or C<Gnu>. |
a737e074 |
145 | |
405ff068 |
146 | As a special case, if the value of this variable is space-separated, |
147 | the tail might be used to disable the ornaments by setting the tail to |
148 | be C<o=0> or C<ornaments=0>. The head should be as described above, say |
149 | |
150 | If the variable is not set, or if the head of space-separated list is |
151 | empty, the best available package is loaded. |
152 | |
153 | export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments |
154 | export "PERL_RL= o=0" # Use best available ReadLine without ornaments |
155 | |
156 | (Note that processing of C<PERL_RL> for ornaments is in the discretion of the |
157 | particular used C<Term::ReadLine::*> package). |
a737e074 |
158 | |
4c3ccbe1 |
159 | =head1 CAVEATS |
160 | |
161 | It seems that using Term::ReadLine from Emacs minibuffer doesn't work |
162 | quite right and one will get an error message like |
163 | |
164 | Cannot open /dev/tty for read at ... |
165 | |
166 | One possible workaround for this is to explicitly open /dev/tty like this |
167 | |
168 | open (FH, "/dev/tty" ) |
169 | or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }'; |
170 | die $@ if $@; |
171 | close (FH); |
172 | |
173 | or you can try using the 4-argument form of Term::ReadLine->new(). |
174 | |
cb31d310 |
175 | =cut |
176 | |
b75c8c73 |
177 | use strict; |
178 | |
cb31d310 |
179 | package Term::ReadLine::Stub; |
b75c8c73 |
180 | our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; |
cb31d310 |
181 | |
182 | $DB::emacs = $DB::emacs; # To peacify -w |
b75c8c73 |
183 | our @rl_term_set; |
7a2e2cd6 |
184 | *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; |
cb31d310 |
185 | |
2499d329 |
186 | sub PERL_UNICODE_STDIN () { 0x0001 } |
187 | |
cb31d310 |
188 | sub ReadLine {'Term::ReadLine::Stub'} |
189 | sub readline { |
a737e074 |
190 | my $self = shift; |
191 | my ($in,$out,$str) = @$self; |
6d697788 |
192 | my $prompt = shift; |
193 | print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; |
a737e074 |
194 | $self->register_Tk |
195 | if not $Term::ReadLine::registered and $Term::ReadLine::toloop |
196 | and defined &Tk::DoOneEvent; |
197 | #$str = scalar <$in>; |
198 | $str = $self->get_line; |
6d697788 |
199 | $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS'); |
2499d329 |
200 | utf8::upgrade($str) |
11412ee6 |
201 | if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) && |
202 | utf8::valid($str); |
7a2e2cd6 |
203 | print $out $rl_term_set[3]; |
cb31d310 |
204 | # bug in 5.000: chomping empty string creats length -1: |
205 | chomp $str if defined $str; |
206 | $str; |
207 | } |
208 | sub addhistory {} |
209 | |
210 | sub findConsole { |
211 | my $console; |
3b2be7b3 |
212 | my $consoleOUT; |
cb31d310 |
213 | |
6d697788 |
214 | if ($^O eq 'MacOS') { |
215 | $console = "Dev:Console"; |
216 | } elsif (-e "/dev/tty") { |
cb31d310 |
217 | $console = "/dev/tty"; |
8878e869 |
218 | } elsif (-e "con" or $^O eq 'MSWin32') { |
3b2be7b3 |
219 | $console = 'CONIN$'; |
220 | $consoleOUT = 'CONOUT$'; |
cb31d310 |
221 | } else { |
222 | $console = "sys\$command"; |
223 | } |
224 | |
4d2c4e07 |
225 | if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) { |
287f63d2 |
226 | $console = undef; |
227 | } |
228 | elsif ($^O eq 'os2') { |
cb31d310 |
229 | if ($DB::emacs) { |
230 | $console = undef; |
231 | } else { |
232 | $console = "/dev/con"; |
233 | } |
234 | } |
235 | |
3b2be7b3 |
236 | $consoleOUT = $console unless defined $consoleOUT; |
cb31d310 |
237 | $console = "&STDIN" unless defined $console; |
238 | if (!defined $consoleOUT) { |
3b2be7b3 |
239 | $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT"; |
cb31d310 |
240 | } |
241 | ($console,$consoleOUT); |
242 | } |
243 | |
244 | sub new { |
245 | die "method new called with wrong number of arguments" |
246 | unless @_==2 or @_==4; |
247 | #local (*FIN, *FOUT); |
405ff068 |
248 | my ($FIN, $FOUT, $ret); |
cb31d310 |
249 | if (@_==2) { |
4c3ccbe1 |
250 | my($console, $consoleOUT) = $_[0]->findConsole; |
cb31d310 |
251 | |
3b2be7b3 |
252 | |
253 | # the Windows CONIN$ needs GENERIC_WRITE mode to allow |
254 | # a SetConsoleMode() if we end up using Term::ReadKey |
255 | open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" : |
256 | "<$console"; |
257 | open FOUT,">$consoleOUT"; |
258 | |
cb31d310 |
259 | #OUT->autoflush(1); # Conflicts with debugger? |
b75c8c73 |
260 | my $sel = select(FOUT); |
cb31d310 |
261 | $| = 1; # for DB::OUT |
262 | select($sel); |
405ff068 |
263 | $ret = bless [\*FIN, \*FOUT]; |
cb31d310 |
264 | } else { # Filehandles supplied |
265 | $FIN = $_[2]; $FOUT = $_[3]; |
266 | #OUT->autoflush(1); # Conflicts with debugger? |
b75c8c73 |
267 | my $sel = select($FOUT); |
cb31d310 |
268 | $| = 1; # for DB::OUT |
269 | select($sel); |
405ff068 |
270 | $ret = bless [$FIN, $FOUT]; |
cb31d310 |
271 | } |
405ff068 |
272 | if ($ret->Features->{ornaments} |
273 | and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) { |
274 | local $Term::ReadLine::termcap_nowarn = 1; |
275 | $ret->ornaments(1); |
276 | } |
277 | return $ret; |
cb31d310 |
278 | } |
f36776d9 |
279 | |
280 | sub newTTY { |
281 | my ($self, $in, $out) = @_; |
282 | $self->[0] = $in; |
283 | $self->[1] = $out; |
284 | my $sel = select($out); |
285 | $| = 1; # for DB::OUT |
286 | select($sel); |
287 | } |
288 | |
cb31d310 |
289 | sub IN { shift->[0] } |
290 | sub OUT { shift->[1] } |
291 | sub MinLine { undef } |
a737e074 |
292 | sub Attribs { {} } |
293 | |
84902520 |
294 | my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); |
a737e074 |
295 | sub Features { \%features } |
cb31d310 |
296 | |
297 | package Term::ReadLine; # So late to allow the above code be defined? |
a737e074 |
298 | |
98225a64 |
299 | our $VERSION = '1.02'; |
b75c8c73 |
300 | |
405ff068 |
301 | my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; |
a737e074 |
302 | if ($which) { |
303 | if ($which =~ /\bgnu\b/i){ |
304 | eval "use Term::ReadLine::Gnu;"; |
305 | } elsif ($which =~ /\bperl\b/i) { |
306 | eval "use Term::ReadLine::Perl;"; |
307 | } else { |
308 | eval "use Term::ReadLine::$which;"; |
309 | } |
405ff068 |
310 | } elsif (defined $which and $which ne '') { # Defined but false |
a737e074 |
311 | # Do nothing fancy |
312 | } else { |
313 | eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; |
314 | } |
cb31d310 |
315 | |
316 | #require FileHandle; |
317 | |
318 | # To make possible switch off RL in debugger: (Not needed, work done |
319 | # in debugger). |
b75c8c73 |
320 | our @ISA; |
cb31d310 |
321 | if (defined &Term::ReadLine::Gnu::readline) { |
322 | @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); |
323 | } elsif (defined &Term::ReadLine::Perl::readline) { |
324 | @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub); |
e15d0a48 |
325 | } elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) { |
326 | @ISA = "Term::ReadLine::$which"; |
cb31d310 |
327 | } else { |
328 | @ISA = qw(Term::ReadLine::Stub); |
329 | } |
330 | |
7a2e2cd6 |
331 | package Term::ReadLine::TermCap; |
332 | |
333 | # Prompt-start, prompt-end, command-line-start, command-line-end |
334 | # -- zero-width beautifies to emit around prompt and the command line. |
b75c8c73 |
335 | our @rl_term_set = ("","","",""); |
7a2e2cd6 |
336 | # string encoded: |
b75c8c73 |
337 | our $rl_term_set = ',,,'; |
7a2e2cd6 |
338 | |
b75c8c73 |
339 | our $terminal; |
7a2e2cd6 |
340 | sub LoadTermCap { |
341 | return if defined $terminal; |
342 | |
343 | require Term::Cap; |
344 | $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. |
345 | } |
346 | |
347 | sub ornaments { |
348 | shift; |
349 | return $rl_term_set unless @_; |
350 | $rl_term_set = shift; |
351 | $rl_term_set ||= ',,,'; |
7b8d334a |
352 | $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; |
7a2e2cd6 |
353 | my @ts = split /,/, $rl_term_set, 4; |
354 | eval { LoadTermCap }; |
405ff068 |
355 | unless (defined $terminal) { |
356 | warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn; |
357 | $rl_term_set = ',,,'; |
358 | return; |
359 | } |
7a2e2cd6 |
360 | @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; |
361 | return $rl_term_set; |
362 | } |
363 | |
364 | |
a737e074 |
365 | package Term::ReadLine::Tk; |
366 | |
b75c8c73 |
367 | our($count_handle, $count_DoOne, $count_loop); |
a737e074 |
368 | $count_handle = $count_DoOne = $count_loop = 0; |
369 | |
b75c8c73 |
370 | our($giveup); |
a737e074 |
371 | sub handle {$giveup = 1; $count_handle++} |
372 | |
373 | sub Tk_loop { |
374 | # Tk->tkwait('variable',\$giveup); # needs Widget |
375 | $count_DoOne++, Tk::DoOneEvent(0) until $giveup; |
376 | $count_loop++; |
377 | $giveup = 0; |
378 | } |
379 | |
380 | sub register_Tk { |
381 | my $self = shift; |
382 | $Term::ReadLine::registered++ |
383 | or Tk->fileevent($self->IN,'readable',\&handle); |
384 | } |
385 | |
386 | sub tkRunning { |
387 | $Term::ReadLine::toloop = $_[1] if @_ > 1; |
388 | $Term::ReadLine::toloop; |
389 | } |
390 | |
391 | sub get_c { |
392 | my $self = shift; |
393 | $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; |
394 | return getc $self->IN; |
395 | } |
396 | |
397 | sub get_line { |
398 | my $self = shift; |
399 | $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; |
400 | my $in = $self->IN; |
4e83e451 |
401 | local ($/) = "\n"; |
a737e074 |
402 | return scalar <$in>; |
403 | } |
cb31d310 |
404 | |
405 | 1; |
406 | |