Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | package Term::Cap; |
2ef86165 | 2 | |
0ca33fed JS |
3 | # Since the debugger uses Term::ReadLine which uses Term::Cap, we want |
4 | # to load as few modules as possible. This includes Carp.pm. | |
085f5cc4 RGS |
5 | sub carp |
6 | { | |
0ca33fed JS |
7 | require Carp; |
8 | goto &Carp::carp; | |
9 | } | |
10 | ||
085f5cc4 RGS |
11 | sub croak |
12 | { | |
0ca33fed JS |
13 | require Carp; |
14 | goto &Carp::croak; | |
15 | } | |
16 | ||
7cae2445 | 17 | use strict; |
85e6fe83 | 18 | |
d2492938 | 19 | use vars qw($VERSION $VMS_TERMCAP); |
7cae2445 | 20 | use vars qw($termpat $state $first $entry); |
2ef86165 | 21 | |
63dc8a94 | 22 | $VERSION = '1.15'; |
b75c8c73 | 23 | |
e14c93b3 DL |
24 | # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com |
25 | # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com | |
26 | # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/ | |
27 | # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu | |
28 | # Avoid warnings in Tgetent and Tputs | |
2ef86165 JS |
29 | # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com |
30 | # Altered layout of the POD | |
31 | # Added Test::More to PREREQ_PM in Makefile.PL | |
32 | # Fixed no argument Tgetent() | |
2ab0daaa JS |
33 | # Version 1.03: Wed Nov 28 10:09:38 GMT 2001 |
34 | # VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu> | |
2608af5d JS |
35 | # Version 1.04: Thu Nov 29 16:22:03 GMT 2001 |
36 | # Fixed warnings in test | |
7cae2445 JS |
37 | # Version 1.05: Mon Dec 3 15:33:49 GMT 2001 |
38 | # Don't try to fall back on infocmp if it's not there. From chromatic. | |
d2492938 JS |
39 | # Version 1.06: Thu Dec 6 18:43:22 GMT 2001 |
40 | # Preload the default VMS termcap from Charles Lane | |
41 | # Don't carp at setting OSPEED unless warnings are on. | |
8bb18277 JS |
42 | # Version 1.07: Wed Jan 2 21:35:09 GMT 2002 |
43 | # Sanity check on infocmp output from Norton Allen | |
44 | # Repaired INSTALLDIRS thanks to Michael Schwern | |
0ca33fed JS |
45 | # Version 1.08: Sat Sep 28 11:33:15 BST 2002 |
46 | # Late loading of 'Carp' as per Michael Schwern | |
47 | # Version 1.09: Tue Apr 20 12:06:51 BST 2004 | |
48 | # Merged in changes from and to Core | |
49 | # Core (Fri Aug 30 14:15:55 CEST 2002): | |
50 | # Cope with comments lines from 'infocmp' from Brendan O'Dea | |
51 | # Allow for EBCDIC in Tgoto magic test. | |
085f5cc4 RGS |
52 | # Version 1.10: Thu Oct 18 16:52:20 BST 2007 |
53 | # Don't use try to use $ENV{HOME} if it doesn't exist | |
54 | # Give Win32 'dumb' if TERM isn't set | |
55 | # Provide fallback 'dumb' termcap entry as last resort | |
305a762d JS |
56 | # Version 1.11: Thu Oct 25 09:33:07 BST 2007 |
57 | # EBDIC fixes from Chun Bing Ge <gecb@cn.ibm.com> | |
76ea3a66 JS |
58 | # Version 1.12: Sat Dec 8 00:10:21 GMT 2007 |
59 | # QNX test fix from Matt Kraai <kraai@ftbfs.org> | |
b9411ff2 DH |
60 | # Version 1.13: Thu Dec 22 22:21:09 GMT 2011 |
61 | # POD error fix from Domin Hargreaves <dom@earth.li> | |
63dc8a94 CBW |
62 | # Version 1.14 Sat Oct 26 19:16:38 BST 2013 |
63 | # Applied all patches from RT and updated contact details | |
64 | # Version 1.15 Sat Oct 26 21:32:24 BST 2013 | |
65 | # Metadata change from David Steinbrunner | |
66 | # Forgot to update the email somewhere | |
cb1a09d0 AD |
67 | # TODO: |
68 | # support Berkeley DB termcaps | |
cb1a09d0 AD |
69 | # force $FH into callers package? |
70 | # keep $FH in object at Tgetent time? | |
71 | ||
72 | =head1 NAME | |
73 | ||
74 | Term::Cap - Perl termcap interface | |
75 | ||
76 | =head1 SYNOPSIS | |
77 | ||
78 | require Term::Cap; | |
79 | $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; | |
80 | $terminal->Trequire(qw/ce ku kd/); | |
81 | $terminal->Tgoto('cm', $col, $row, $FH); | |
82 | $terminal->Tputs('dl', $count, $FH); | |
83 | $terminal->Tpad($string, $count, $FH); | |
84 | ||
85 | =head1 DESCRIPTION | |
86 | ||
87 | These are low-level functions to extract and use capabilities from | |
88 | a terminal capability (termcap) database. | |
89 | ||
2ef86165 JS |
90 | More information on the terminal capabilities will be found in the |
91 | termcap manpage on most Unix-like systems. | |
cb1a09d0 | 92 | |
2ef86165 | 93 | =head2 METHODS |
cb1a09d0 | 94 | |
cb1a09d0 AD |
95 | The output strings for B<Tputs> are cached for counts of 1 for performance. |
96 | B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap | |
97 | data and C<$self-E<gt>{xx}> is the cached version. | |
98 | ||
99 | print $terminal->Tpad($self->{_xx}, 1); | |
100 | ||
101 | B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also | |
102 | output the string to $FH if specified. | |
103 | ||
cb1a09d0 AD |
104 | |
105 | =cut | |
106 | ||
d2492938 JS |
107 | # Preload the default VMS termcap. |
108 | # If a different termcap is required then the text of one can be supplied | |
109 | # in $Term::Cap::VMS_TERMCAP before Tgetent is called. | |
110 | ||
085f5cc4 RGS |
111 | if ( $^O eq 'VMS' ) |
112 | { | |
113 | chomp( my @entry = <DATA> ); | |
114 | $VMS_TERMCAP = join '', @entry; | |
d2492938 JS |
115 | } |
116 | ||
cb1a09d0 | 117 | # Returns a list of termcap files to check. |
d2492938 | 118 | |
085f5cc4 RGS |
119 | sub termcap_path |
120 | { ## private | |
cb1a09d0 | 121 | my @termcap_path; |
085f5cc4 | 122 | |
cb1a09d0 | 123 | # $TERMCAP, if it's a filespec |
085f5cc4 RGS |
124 | push( @termcap_path, $ENV{TERMCAP} ) |
125 | if ( | |
126 | ( exists $ENV{TERMCAP} ) | |
127 | && ( | |
128 | ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ) | |
129 | ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is | |
130 | : $ENV{TERMCAP} =~ /^\//s | |
131 | ) | |
132 | ); | |
133 | if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) ) | |
134 | { | |
135 | ||
136 | # Add the users $TERMPATH | |
137 | push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) ); | |
cb1a09d0 | 138 | } |
085f5cc4 RGS |
139 | else |
140 | { | |
141 | ||
142 | # Defaults | |
143 | push( @termcap_path, | |
144 | exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef, | |
145 | '/etc/termcap', '/usr/share/misc/termcap', ); | |
a687059c | 146 | } |
d2492938 | 147 | |
cb1a09d0 | 148 | # return the list of those termcaps that exist |
085f5cc4 | 149 | return grep { defined $_ && -f $_ } @termcap_path; |
748a9306 LW |
150 | } |
151 | ||
c0e71a27 DH |
152 | =over 4 |
153 | ||
2ef86165 JS |
154 | =item B<Tgetent> |
155 | ||
156 | Returns a blessed object reference which the user can | |
157 | then use to send the control strings to the terminal using B<Tputs> | |
158 | and B<Tgoto>. | |
159 | ||
160 | The function extracts the entry of the specified terminal | |
161 | type I<TERM> (defaults to the environment variable I<TERM>) from the | |
162 | database. | |
163 | ||
164 | It will look in the environment for a I<TERMCAP> variable. If | |
165 | found, and the value does not begin with a slash, and the terminal | |
166 | type name is the same as the environment string I<TERM>, the | |
167 | I<TERMCAP> string is used instead of reading a termcap file. If | |
168 | it does begin with a slash, the string is used as a path name of | |
169 | the termcap file to search. If I<TERMCAP> does not begin with a | |
170 | slash and name is different from I<TERM>, B<Tgetent> searches the | |
171 | files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>, | |
172 | in that order, unless the environment variable I<TERMPATH> exists, | |
173 | in which case it specifies a list of file pathnames (separated by | |
174 | spaces or colons) to be searched B<instead>. Whenever multiple | |
175 | files are searched and a tc field occurs in the requested entry, | |
176 | the entry it names must be found in the same file or one of the | |
177 | succeeding files. If there is a C<:tc=...:> in the I<TERMCAP> | |
178 | environment variable string it will continue the search in the | |
179 | files as above. | |
180 | ||
181 | The extracted termcap entry is available in the object | |
182 | as C<$self-E<gt>{TERMCAP}>. | |
183 | ||
184 | It takes a hash reference as an argument with two optional keys: | |
185 | ||
186 | =over 2 | |
187 | ||
188 | =item OSPEED | |
189 | ||
190 | The terminal output bit rate (often mistakenly called the baud rate) | |
191 | for this terminal - if not set a warning will be generated | |
63dc8a94 | 192 | and it will be defaulted to 9600. I<OSPEED> can be specified as |
2ef86165 JS |
193 | either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or |
194 | an old DSD-style speed ( where 13 equals 9600). | |
195 | ||
196 | ||
197 | =item TERM | |
198 | ||
199 | The terminal type whose termcap entry will be used - if not supplied it will | |
200 | default to $ENV{TERM}: if that is not set then B<Tgetent> will croak. | |
201 | ||
202 | =back | |
203 | ||
204 | It calls C<croak> on failure. | |
205 | ||
206 | =cut | |
207 | ||
085f5cc4 RGS |
208 | sub Tgetent |
209 | { ## public -- static method | |
cb1a09d0 | 210 | my $class = shift; |
2ef86165 JS |
211 | my ($self) = @_; |
212 | ||
213 | $self = {} unless defined $self; | |
214 | bless $self, $class; | |
215 | ||
085f5cc4 RGS |
216 | my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP ); |
217 | local ( $termpat, $state, $first, $entry ); # used inside eval | |
cb1a09d0 AD |
218 | local $_; |
219 | ||
220 | # Compute PADDING factor from OSPEED (to be used by Tpad) | |
085f5cc4 RGS |
221 | if ( !$self->{OSPEED} ) |
222 | { | |
223 | if ($^W) | |
224 | { | |
225 | carp "OSPEED was not set, defaulting to 9600"; | |
d2492938 | 226 | } |
085f5cc4 | 227 | $self->{OSPEED} = 9600; |
cb1a09d0 | 228 | } |
085f5cc4 RGS |
229 | if ( $self->{OSPEED} < 16 ) |
230 | { | |
231 | ||
232 | # delays for old style speeds | |
233 | my @pad = ( | |
234 | 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3, | |
235 | 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2 | |
236 | ); | |
237 | $self->{PADDING} = $pad[ $self->{OSPEED} ]; | |
cb1a09d0 | 238 | } |
085f5cc4 RGS |
239 | else |
240 | { | |
241 | $self->{PADDING} = 10000 / $self->{OSPEED}; | |
cb1a09d0 AD |
242 | } |
243 | ||
085f5cc4 RGS |
244 | unless ( $self->{TERM} ) |
245 | { | |
246 | if ( $ENV{TERM} ) | |
247 | { | |
248 | $self->{TERM} = $ENV{TERM} ; | |
249 | } | |
250 | else | |
251 | { | |
63dc8a94 | 252 | if ( $^O eq 'MSWin32' ) |
085f5cc4 RGS |
253 | { |
254 | $self->{TERM} = 'dumb'; | |
255 | } | |
256 | else | |
257 | { | |
258 | croak "TERM not set"; | |
259 | } | |
260 | } | |
261 | } | |
262 | ||
263 | $term = $self->{TERM}; # $term is the term type we are looking for | |
cb1a09d0 AD |
264 | |
265 | # $tmp_term is always the next term (possibly :tc=...:) we are looking for | |
266 | $tmp_term = $self->{TERM}; | |
cb1a09d0 | 267 | |
085f5cc4 RGS |
268 | # protect any pattern metacharacters in $tmp_term |
269 | $termpat = $tmp_term; | |
270 | $termpat =~ s/(\W)/\\$1/g; | |
271 | ||
272 | my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' ); | |
cb1a09d0 AD |
273 | |
274 | # $entry is the extracted termcap entry | |
085f5cc4 RGS |
275 | if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) ) |
276 | { | |
277 | $entry = $foo; | |
cb1a09d0 AD |
278 | } |
279 | ||
2ef86165 | 280 | my @termcap_path = termcap_path(); |
e66fb0c2 | 281 | |
085f5cc4 | 282 | unless ( @termcap_path || $entry ) |
e66fb0c2 | 283 | { |
2ab0daaa | 284 | |
085f5cc4 RGS |
285 | # last resort--fake up a termcap from terminfo |
286 | local $ENV{TERM} = $term; | |
287 | ||
288 | if ( $^O eq 'VMS' ) | |
289 | { | |
290 | $entry = $VMS_TERMCAP; | |
7cae2445 | 291 | } |
085f5cc4 RGS |
292 | else |
293 | { | |
294 | if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) | |
295 | { | |
296 | eval { | |
297 | my $tmp = `infocmp -C 2>/dev/null`; | |
298 | $tmp =~ s/^#.*\n//gm; # remove comments | |
299 | if ( ( $tmp !~ m%^/%s ) | |
300 | && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) ) | |
301 | { | |
302 | $entry = $tmp; | |
303 | } | |
304 | }; | |
63dc8a94 | 305 | warn "Can't run infocmp to get a termcap entry: $@" if $@; |
085f5cc4 RGS |
306 | } |
307 | else | |
308 | { | |
309 | # this is getting desperate now | |
310 | if ( $self->{TERM} eq 'dumb' ) | |
311 | { | |
312 | $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:'; | |
313 | } | |
314 | } | |
7cae2445 | 315 | } |
2f6e8d9f | 316 | } |
e66fb0c2 | 317 | |
cb1a09d0 AD |
318 | croak "Can't find a valid termcap file" unless @termcap_path || $entry; |
319 | ||
085f5cc4 RGS |
320 | $state = 1; # 0 == finished |
321 | # 1 == next file | |
322 | # 2 == search again | |
cb1a09d0 | 323 | |
085f5cc4 | 324 | $first = 0; # first entry (keeps term name) |
cb1a09d0 | 325 | |
085f5cc4 | 326 | $max = 32; # max :tc=...:'s |
cb1a09d0 | 327 | |
085f5cc4 RGS |
328 | if ($entry) |
329 | { | |
330 | ||
331 | # ok, we're starting with $TERMCAP | |
332 | $first++; # we're the first entry | |
333 | # do we need to continue? | |
334 | if ( $entry =~ s/:tc=([^:]+):/:/ ) | |
335 | { | |
336 | $tmp_term = $1; | |
337 | ||
338 | # protect any pattern metacharacters in $tmp_term | |
339 | $termpat = $tmp_term; | |
340 | $termpat =~ s/(\W)/\\$1/g; | |
341 | } | |
342 | else | |
343 | { | |
344 | $state = 0; # we're already finished | |
345 | } | |
cb1a09d0 AD |
346 | } |
347 | ||
348 | # This is eval'ed inside the while loop for each file | |
349 | $search = q{ | |
54310121 | 350 | while (<TERMCAP>) { |
cb1a09d0 AD |
351 | next if /^\\t/ || /^#/; |
352 | if ($_ =~ m/(^|\\|)${termpat}[:|]/o) { | |
353 | chomp; | |
354 | s/^[^:]*:// if $first++; | |
355 | $state = 0; | |
54310121 | 356 | while ($_ =~ s/\\\\$//) { |
357 | defined(my $x = <TERMCAP>) or last; | |
358 | $_ .= $x; chomp; | |
359 | } | |
cb1a09d0 | 360 | last; |
748a9306 | 361 | } |
cb1a09d0 | 362 | } |
55497cff | 363 | defined $entry or $entry = ''; |
e14c93b3 | 364 | $entry .= $_ if $_; |
cb1a09d0 | 365 | }; |
748a9306 | 366 | |
085f5cc4 RGS |
367 | while ( $state != 0 ) |
368 | { | |
369 | if ( $state == 1 ) | |
370 | { | |
371 | ||
372 | # get the next TERMCAP | |
373 | $TERMCAP = shift @termcap_path | |
374 | || croak "failed termcap lookup on $tmp_term"; | |
375 | } | |
376 | else | |
377 | { | |
378 | ||
379 | # do the same file again | |
380 | # prevent endless recursion | |
381 | $max-- || croak "failed termcap loop at $tmp_term"; | |
382 | $state = 1; # ok, maybe do a new file next time | |
383 | } | |
384 | ||
385 | open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!"; | |
386 | eval $search; | |
387 | die $@ if $@; | |
388 | close TERMCAP; | |
cb1a09d0 | 389 | |
085f5cc4 RGS |
390 | # If :tc=...: found then search this file again |
391 | $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 ); | |
cb1a09d0 | 392 | |
085f5cc4 RGS |
393 | # protect any pattern metacharacters in $tmp_term |
394 | $termpat = $tmp_term; | |
395 | $termpat =~ s/(\W)/\\$1/g; | |
a687059c | 396 | } |
cb1a09d0 AD |
397 | |
398 | croak "Can't find $term" if $entry eq ''; | |
085f5cc4 RGS |
399 | $entry =~ s/:+\s*:+/:/g; # cleanup $entry |
400 | $entry =~ s/:+/:/g; # cleanup $entry | |
401 | $self->{TERMCAP} = $entry; # save it | |
402 | # print STDERR "DEBUG: $entry = ", $entry, "\n"; | |
a687059c | 403 | |
748a9306 | 404 | # Precompile $entry into the object |
cb1a09d0 | 405 | $entry =~ s/^[^:]*://; |
085f5cc4 RGS |
406 | foreach $field ( split( /:[\s:\\]*/, $entry ) ) |
407 | { | |
408 | if ( defined $field && $field =~ /^(\w\w)$/ ) | |
409 | { | |
410 | $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 }; | |
411 | ||
412 | # print STDERR "DEBUG: flag $1\n"; | |
413 | } | |
414 | elsif ( defined $field && $field =~ /^(\w\w)\@/ ) | |
415 | { | |
416 | $self->{ '_' . $1 } = ""; | |
417 | ||
418 | # print STDERR "DEBUG: unset $1\n"; | |
419 | } | |
420 | elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ ) | |
421 | { | |
422 | $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 }; | |
423 | ||
424 | # print STDERR "DEBUG: numeric $1 = $2\n"; | |
425 | } | |
426 | elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ ) | |
427 | { | |
428 | ||
429 | # print STDERR "DEBUG: string $1 = $2\n"; | |
430 | next if defined $self->{ '_' . ( $cap = $1 ) }; | |
431 | $_ = $2; | |
305a762d JS |
432 | if ( ord('A') == 193 ) |
433 | { | |
434 | s/\\E/\047/g; | |
435 | s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; | |
436 | s/\\n/\n/g; | |
437 | s/\\r/\r/g; | |
438 | s/\\t/\t/g; | |
439 | s/\\b/\b/g; | |
440 | s/\\f/\f/g; | |
441 | s/\\\^/\337/g; | |
442 | s/\^\?/\007/g; | |
443 | s/\^(.)/pack('c',ord($1) & 31)/eg; | |
444 | s/\\(.)/$1/g; | |
445 | s/\337/^/g; | |
446 | } | |
447 | else | |
448 | { | |
449 | s/\\E/\033/g; | |
450 | s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; | |
451 | s/\\n/\n/g; | |
452 | s/\\r/\r/g; | |
453 | s/\\t/\t/g; | |
454 | s/\\b/\b/g; | |
455 | s/\\f/\f/g; | |
456 | s/\\\^/\377/g; | |
457 | s/\^\?/\177/g; | |
458 | s/\^(.)/pack('c',ord($1) & 31)/eg; | |
459 | s/\\(.)/$1/g; | |
460 | s/\377/^/g; | |
461 | } | |
085f5cc4 RGS |
462 | $self->{ '_' . $cap } = $_; |
463 | } | |
464 | ||
465 | # else { carp "junk in $term ignored: $field"; } | |
a687059c | 466 | } |
cb1a09d0 AD |
467 | $self->{'_pc'} = "\0" unless defined $self->{'_pc'}; |
468 | $self->{'_bc'} = "\b" unless defined $self->{'_bc'}; | |
469 | $self; | |
a687059c LW |
470 | } |
471 | ||
cb1a09d0 | 472 | # $terminal->Tpad($string, $cnt, $FH); |
2ef86165 JS |
473 | |
474 | =item B<Tpad> | |
475 | ||
476 | Outputs a literal string with appropriate padding for the current terminal. | |
477 | ||
478 | It takes three arguments: | |
479 | ||
480 | =over 2 | |
481 | ||
482 | =item B<$string> | |
483 | ||
484 | The literal string to be output. If it starts with a number and an optional | |
485 | '*' then the padding will be increased by an amount relative to this number, | |
63dc8a94 | 486 | if the '*' is present then this amount will be multiplied by $cnt. This part |
2ef86165 JS |
487 | of $string is removed before output/ |
488 | ||
489 | =item B<$cnt> | |
490 | ||
491 | Will be used to modify the padding applied to string as described above. | |
492 | ||
493 | =item B<$FH> | |
494 | ||
495 | An optional filehandle (or IO::Handle ) that output will be printed to. | |
496 | ||
497 | =back | |
498 | ||
499 | The padded $string is returned. | |
500 | ||
501 | =cut | |
502 | ||
085f5cc4 RGS |
503 | sub Tpad |
504 | { ## public | |
cb1a09d0 | 505 | my $self = shift; |
085f5cc4 RGS |
506 | my ( $string, $cnt, $FH ) = @_; |
507 | my ( $decr, $ms ); | |
508 | ||
509 | if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ ) | |
510 | { | |
511 | $ms = $1; | |
512 | $ms *= $cnt if $2; | |
513 | $string = $3; | |
514 | $decr = $self->{PADDING}; | |
515 | if ( $decr > .1 ) | |
516 | { | |
517 | $ms += $decr / 2; | |
518 | $string .= $self->{'_pc'} x ( $ms / $decr ); | |
519 | } | |
a687059c LW |
520 | } |
521 | print $FH $string if $FH; | |
522 | $string; | |
523 | } | |
524 | ||
cb1a09d0 | 525 | # $terminal->Tputs($cap, $cnt, $FH); |
2ef86165 JS |
526 | |
527 | =item B<Tputs> | |
528 | ||
529 | Output the string for the given capability padded as appropriate without | |
530 | any parameter substitution. | |
531 | ||
532 | It takes three arguments: | |
533 | ||
534 | =over 2 | |
535 | ||
536 | =item B<$cap> | |
537 | ||
538 | The capability whose string is to be output. | |
539 | ||
540 | =item B<$cnt> | |
541 | ||
542 | A count passed to Tpad to modify the padding applied to the output string. | |
543 | If $cnt is zero or one then the resulting string will be cached. | |
544 | ||
545 | =item B<$FH> | |
546 | ||
547 | An optional filehandle (or IO::Handle ) that output will be printed to. | |
548 | ||
549 | =back | |
550 | ||
551 | The appropriate string for the capability will be returned. | |
552 | ||
553 | =cut | |
554 | ||
085f5cc4 RGS |
555 | sub Tputs |
556 | { ## public | |
cb1a09d0 | 557 | my $self = shift; |
085f5cc4 | 558 | my ( $cap, $cnt, $FH ) = @_; |
cb1a09d0 | 559 | my $string; |
748a9306 | 560 | |
2ef86165 JS |
561 | $cnt = 0 unless $cnt; |
562 | ||
085f5cc4 RGS |
563 | if ( $cnt > 1 ) |
564 | { | |
565 | $string = Tpad( $self, $self->{ '_' . $cap }, $cnt ); | |
566 | } | |
567 | else | |
568 | { | |
569 | ||
570 | # cache result because Tpad can be slow | |
571 | unless ( exists $self->{$cap} ) | |
572 | { | |
573 | $self->{$cap} = | |
574 | exists $self->{"_$cap"} | |
575 | ? Tpad( $self, $self->{"_$cap"}, 1 ) | |
576 | : undef; | |
577 | } | |
578 | $string = $self->{$cap}; | |
748a9306 LW |
579 | } |
580 | print $FH $string if $FH; | |
581 | $string; | |
582 | } | |
583 | ||
cb1a09d0 | 584 | # $terminal->Tgoto($cap, $col, $row, $FH); |
2ef86165 JS |
585 | |
586 | =item B<Tgoto> | |
587 | ||
588 | B<Tgoto> decodes a cursor addressing string with the given parameters. | |
589 | ||
590 | There are four arguments: | |
591 | ||
592 | =over 2 | |
593 | ||
594 | =item B<$cap> | |
595 | ||
596 | The name of the capability to be output. | |
597 | ||
598 | =item B<$col> | |
599 | ||
600 | The first value to be substituted in the output string ( usually the column | |
601 | in a cursor addressing capability ) | |
602 | ||
603 | =item B<$row> | |
604 | ||
605 | The second value to be substituted in the output string (usually the row | |
606 | in cursor addressing capabilities) | |
607 | ||
608 | =item B<$FH> | |
609 | ||
610 | An optional filehandle (or IO::Handle ) to which the output string will be | |
611 | printed. | |
612 | ||
613 | =back | |
614 | ||
615 | Substitutions are made with $col and $row in the output string with the | |
616 | following sprintf() line formats: | |
617 | ||
618 | %% output `%' | |
619 | %d output value as in printf %d | |
620 | %2 output value as in printf %2d | |
621 | %3 output value as in printf %3d | |
622 | %. output value as in printf %c | |
623 | %+x add x to value, then do %. | |
624 | ||
625 | %>xy if value > x then add y, no output | |
626 | %r reverse order of two parameters, no output | |
627 | %i increment by one, no output | |
628 | %B BCD (16*(value/10)) + (value%10), no output | |
629 | ||
630 | %n exclusive-or all parameters with 0140 (Datamedia 2500) | |
631 | %D Reverse coding (value - 2*(value%16)), no output (Delta Data) | |
632 | ||
633 | The output string will be returned. | |
634 | ||
635 | =cut | |
636 | ||
085f5cc4 RGS |
637 | sub Tgoto |
638 | { ## public | |
cb1a09d0 | 639 | my $self = shift; |
085f5cc4 RGS |
640 | my ( $cap, $code, $tmp, $FH ) = @_; |
641 | my $string = $self->{ '_' . $cap }; | |
cb1a09d0 | 642 | my $result = ''; |
085f5cc4 | 643 | my $after = ''; |
cb1a09d0 | 644 | my $online = 0; |
085f5cc4 RGS |
645 | my @tmp = ( $tmp, $code ); |
646 | my $cnt = $code; | |
647 | ||
648 | while ( $string =~ /^([^%]*)%(.)(.*)/ ) | |
649 | { | |
650 | $result .= $1; | |
651 | $code = $2; | |
652 | $string = $3; | |
653 | if ( $code eq 'd' ) | |
654 | { | |
655 | $result .= sprintf( "%d", shift(@tmp) ); | |
656 | } | |
657 | elsif ( $code eq '.' ) | |
658 | { | |
659 | $tmp = shift(@tmp); | |
660 | if ( $tmp == 0 || $tmp == 4 || $tmp == 10 ) | |
661 | { | |
662 | if ($online) | |
663 | { | |
664 | ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; | |
665 | } | |
666 | else | |
667 | { | |
668 | ++$tmp, $after .= $self->{'_bc'}; | |
669 | } | |
670 | } | |
671 | $result .= sprintf( "%c", $tmp ); | |
672 | $online = !$online; | |
673 | } | |
674 | elsif ( $code eq '+' ) | |
675 | { | |
676 | $result .= sprintf( "%c", shift(@tmp) + ord($string) ); | |
677 | $string = substr( $string, 1, 99 ); | |
678 | $online = !$online; | |
679 | } | |
680 | elsif ( $code eq 'r' ) | |
681 | { | |
682 | ( $code, $tmp ) = @tmp; | |
683 | @tmp = ( $tmp, $code ); | |
684 | $online = !$online; | |
685 | } | |
686 | elsif ( $code eq '>' ) | |
687 | { | |
688 | ( $code, $tmp, $string ) = unpack( "CCa99", $string ); | |
63dc8a94 | 689 | if ( $tmp[0] > $code ) |
085f5cc4 | 690 | { |
63dc8a94 | 691 | $tmp[0] += $tmp; |
085f5cc4 RGS |
692 | } |
693 | } | |
694 | elsif ( $code eq '2' ) | |
695 | { | |
696 | $result .= sprintf( "%02d", shift(@tmp) ); | |
697 | $online = !$online; | |
698 | } | |
699 | elsif ( $code eq '3' ) | |
700 | { | |
701 | $result .= sprintf( "%03d", shift(@tmp) ); | |
702 | $online = !$online; | |
703 | } | |
704 | elsif ( $code eq 'i' ) | |
705 | { | |
706 | ( $code, $tmp ) = @tmp; | |
707 | @tmp = ( $code + 1, $tmp + 1 ); | |
708 | } | |
709 | else | |
710 | { | |
711 | return "OOPS"; | |
712 | } | |
a687059c | 713 | } |
085f5cc4 | 714 | $string = Tpad( $self, $result . $string . $after, $cnt ); |
748a9306 LW |
715 | print $FH $string if $FH; |
716 | $string; | |
717 | } | |
718 | ||
cb1a09d0 | 719 | # $terminal->Trequire(qw/ce ku kd/); |
2ef86165 JS |
720 | |
721 | =item B<Trequire> | |
722 | ||
723 | Takes a list of capabilities as an argument and will croak if one is not | |
724 | found. | |
725 | ||
726 | =cut | |
727 | ||
085f5cc4 RGS |
728 | sub Trequire |
729 | { ## public | |
cb1a09d0 | 730 | my $self = shift; |
085f5cc4 RGS |
731 | my ( $cap, @undefined ); |
732 | foreach $cap (@_) | |
733 | { | |
734 | push( @undefined, $cap ) | |
735 | unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap }; | |
748a9306 | 736 | } |
cb1a09d0 | 737 | croak "Terminal does not support: (@undefined)" if @undefined; |
a687059c LW |
738 | } |
739 | ||
2ef86165 JS |
740 | =back |
741 | ||
742 | =head1 EXAMPLES | |
743 | ||
744 | use Term::Cap; | |
745 | ||
746 | # Get terminal output speed | |
747 | require POSIX; | |
748 | my $termios = new POSIX::Termios; | |
749 | $termios->getattr; | |
750 | my $ospeed = $termios->getospeed; | |
751 | ||
752 | # Old-style ioctl code to get ospeed: | |
753 | # require 'ioctl.pl'; | |
754 | # ioctl(TTY,$TIOCGETP,$sgtty); | |
755 | # ($ispeed,$ospeed) = unpack('cc',$sgtty); | |
756 | ||
757 | # allocate and initialize a terminal structure | |
758 | $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; | |
759 | ||
760 | # require certain capabilities to be available | |
761 | $terminal->Trequire(qw/ce ku kd/); | |
762 | ||
763 | # Output Routines, if $FH is undefined these just return the string | |
cb1a09d0 | 764 | |
2ef86165 JS |
765 | # Tgoto does the % expansion stuff with the given args |
766 | $terminal->Tgoto('cm', $col, $row, $FH); | |
767 | ||
768 | # Tputs doesn't do any % expansion. | |
769 | $terminal->Tputs('dl', $count = 1, $FH); | |
770 | ||
771 | =head1 COPYRIGHT AND LICENSE | |
772 | ||
773 | Please see the README file in distribution. | |
774 | ||
775 | =head1 AUTHOR | |
776 | ||
777 | This module is part of the core Perl distribution and is also maintained | |
63dc8a94 CBW |
778 | for CPAN by Jonathan Stowe <jns@gellyfish.co.uk>. |
779 | ||
780 | The code is hosted on Github: https://github.com/jonathanstowe/Term-Cap | |
781 | please feel free to fork, submit patches etc, etc there. | |
2ef86165 JS |
782 | |
783 | =head1 SEE ALSO | |
784 | ||
785 | termcap(5) | |
786 | ||
787 | =cut | |
2ab0daaa JS |
788 | |
789 | # Below is a default entry for systems where there are terminals but no | |
790 | # termcap | |
791 | 1; | |
a69e7784 | 792 | __DATA__ |
2ab0daaa JS |
793 | vt220|vt200|DEC VT220 in vt100 emulation mode: |
794 | am:mi:xn:xo: | |
795 | co#80:li#24: | |
796 | RA=\E[?7l:SA=\E[?7h: | |
797 | ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0: | |
798 | bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH: | |
799 | cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B: | |
800 | ei=\E[4l:ho=\E[H:im=\E[4h: | |
801 | is=\E[1;24r\E[24;1H: | |
802 | nd=\E[C: | |
803 | kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H: | |
804 | mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m: | |
805 | kb=\0177: | |
806 | r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8: | |
807 | sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I: | |
808 | ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: | |
809 |