Commit | Line | Data |
---|---|---|
86530b38 AT |
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 |