This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate CPAN release of version.pm 0.9905
[perl5.git] / cpan / Term-Cap / Cap.pm
CommitLineData
a0d0e21e 1package 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
5sub carp
6{
0ca33fed
JS
7 require Carp;
8 goto &Carp::carp;
9}
10
085f5cc4
RGS
11sub croak
12{
0ca33fed
JS
13 require Carp;
14 goto &Carp::croak;
15}
16
7cae2445 17use strict;
85e6fe83 18
d2492938 19use vars qw($VERSION $VMS_TERMCAP);
7cae2445 20use 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
74Term::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
87These are low-level functions to extract and use capabilities from
88a terminal capability (termcap) database.
89
2ef86165
JS
90More information on the terminal capabilities will be found in the
91termcap manpage on most Unix-like systems.
cb1a09d0 92
2ef86165 93=head2 METHODS
cb1a09d0 94
cb1a09d0
AD
95The output strings for B<Tputs> are cached for counts of 1 for performance.
96B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
97data and C<$self-E<gt>{xx}> is the cached version.
98
99 print $terminal->Tpad($self->{_xx}, 1);
100
101B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
102output 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
111if ( $^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
119sub 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
156Returns a blessed object reference which the user can
157then use to send the control strings to the terminal using B<Tputs>
158and B<Tgoto>.
159
160The function extracts the entry of the specified terminal
161type I<TERM> (defaults to the environment variable I<TERM>) from the
162database.
163
164It will look in the environment for a I<TERMCAP> variable. If
165found, and the value does not begin with a slash, and the terminal
166type name is the same as the environment string I<TERM>, the
167I<TERMCAP> string is used instead of reading a termcap file. If
168it does begin with a slash, the string is used as a path name of
169the termcap file to search. If I<TERMCAP> does not begin with a
170slash and name is different from I<TERM>, B<Tgetent> searches the
171files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
172in that order, unless the environment variable I<TERMPATH> exists,
173in which case it specifies a list of file pathnames (separated by
174spaces or colons) to be searched B<instead>. Whenever multiple
175files are searched and a tc field occurs in the requested entry,
176the entry it names must be found in the same file or one of the
177succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
178environment variable string it will continue the search in the
179files as above.
180
181The extracted termcap entry is available in the object
182as C<$self-E<gt>{TERMCAP}>.
183
184It takes a hash reference as an argument with two optional keys:
185
186=over 2
187
188=item OSPEED
189
190The terminal output bit rate (often mistakenly called the baud rate)
191for this terminal - if not set a warning will be generated
63dc8a94 192and it will be defaulted to 9600. I<OSPEED> can be specified as
2ef86165
JS
193either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
194an old DSD-style speed ( where 13 equals 9600).
195
196
197=item TERM
198
199The terminal type whose termcap entry will be used - if not supplied it will
200default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
201
202=back
203
204It calls C<croak> on failure.
205
206=cut
207
085f5cc4
RGS
208sub 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
PP
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
476Outputs a literal string with appropriate padding for the current terminal.
477
478It takes three arguments:
479
480=over 2
481
482=item B<$string>
483
484The 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 486if the '*' is present then this amount will be multiplied by $cnt. This part
2ef86165
JS
487of $string is removed before output/
488
489=item B<$cnt>
490
491Will be used to modify the padding applied to string as described above.
492
493=item B<$FH>
494
495An optional filehandle (or IO::Handle ) that output will be printed to.
496
497=back
498
499The padded $string is returned.
500
501=cut
502
085f5cc4
RGS
503sub 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
529Output the string for the given capability padded as appropriate without
530any parameter substitution.
531
532It takes three arguments:
533
534=over 2
535
536=item B<$cap>
537
538The capability whose string is to be output.
539
540=item B<$cnt>
541
542A count passed to Tpad to modify the padding applied to the output string.
543If $cnt is zero or one then the resulting string will be cached.
544
545=item B<$FH>
546
547An optional filehandle (or IO::Handle ) that output will be printed to.
548
549=back
550
551The appropriate string for the capability will be returned.
552
553=cut
554
085f5cc4
RGS
555sub 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
588B<Tgoto> decodes a cursor addressing string with the given parameters.
589
590There are four arguments:
591
592=over 2
593
594=item B<$cap>
595
596The name of the capability to be output.
597
598=item B<$col>
599
600The first value to be substituted in the output string ( usually the column
601in a cursor addressing capability )
602
603=item B<$row>
604
605The second value to be substituted in the output string (usually the row
606in cursor addressing capabilities)
607
608=item B<$FH>
609
610An optional filehandle (or IO::Handle ) to which the output string will be
611printed.
612
613=back
614
615Substitutions are made with $col and $row in the output string with the
616following 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
633The output string will be returned.
634
635=cut
636
085f5cc4
RGS
637sub 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
723Takes a list of capabilities as an argument and will croak if one is not
724found.
725
726=cut
727
085f5cc4
RGS
728sub 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
773Please see the README file in distribution.
774
775=head1 AUTHOR
776
777This module is part of the core Perl distribution and is also maintained
63dc8a94
CBW
778for CPAN by Jonathan Stowe <jns@gellyfish.co.uk>.
779
780The code is hosted on Github: https://github.com/jonathanstowe/Term-Cap
781please feel free to fork, submit patches etc, etc there.
2ef86165
JS
782
783=head1 SEE ALSO
784
785termcap(5)
786
787=cut
2ab0daaa
JS
788
789# Below is a default entry for systems where there are terminals but no
790# termcap
7911;
a69e7784 792__DATA__
2ab0daaa
JS
793vt220|vt200|DEC VT220 in vt100 emulation mode:
794am:mi:xn:xo:
795co#80:li#24:
796RA=\E[?7l:SA=\E[?7h:
797ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
798bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
799cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
800ei=\E[4l:ho=\E[H:im=\E[4h:
801is=\E[1;24r\E[24;1H:
802nd=\E[C:
803kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
804mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
805kb=\0177:
806r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
807sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
808ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:
809