6 use vars qw($VERSION $VMS_TERMCAP);
7 use vars qw($termpat $state $first $entry);
11 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
12 # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
13 # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
14 # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
15 # Avoid warnings in Tgetent and Tputs
16 # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
17 # Altered layout of the POD
18 # Added Test::More to PREREQ_PM in Makefile.PL
19 # Fixed no argument Tgetent()
20 # Version 1.03: Wed Nov 28 10:09:38 GMT 2001
21 # VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
22 # Version 1.04: Thu Nov 29 16:22:03 GMT 2001
23 # Fixed warnings in test
24 # Version 1.05: Mon Dec 3 15:33:49 GMT 2001
25 # Don't try to fall back on infocmp if it's not there. From chromatic.
26 # Version 1.06: Thu Dec 6 18:43:22 GMT 2001
27 # Preload the default VMS termcap from Charles Lane
28 # Don't carp at setting OSPEED unless warnings are on.
29 # Version 1.07: Wed Jan 2 21:35:09 GMT 2002
30 # Sanity check on infocmp output from Norton Allen
31 # Repaired INSTALLDIRS thanks to Michael Schwern
34 # support Berkeley DB termcaps
35 # should probably be a .xs module
36 # force $FH into callers package?
37 # keep $FH in object at Tgetent time?
41 Term::Cap - Perl termcap interface
46 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
47 $terminal->Trequire(qw/ce ku kd/);
48 $terminal->Tgoto('cm', $col, $row, $FH);
49 $terminal->Tputs('dl', $count, $FH);
50 $terminal->Tpad($string, $count, $FH);
54 These are low-level functions to extract and use capabilities from
55 a terminal capability (termcap) database.
57 More information on the terminal capabilities will be found in the
58 termcap manpage on most Unix-like systems.
64 The output strings for B<Tputs> are cached for counts of 1 for performance.
65 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
66 data and C<$self-E<gt>{xx}> is the cached version.
68 print $terminal->Tpad($self->{_xx}, 1);
70 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
71 output the string to $FH if specified.
76 # Preload the default VMS termcap.
77 # If a different termcap is required then the text of one can be supplied
78 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
81 chomp (my @entry = <DATA>);
82 $VMS_TERMCAP = join '', @entry;
85 # Returns a list of termcap files to check.
87 sub termcap_path { ## private
89 # $TERMCAP, if it's a filespec
90 push(@termcap_path, $ENV{TERMCAP})
91 if ((exists $ENV{TERMCAP}) &&
92 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
93 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
94 : $ENV{TERMCAP} =~ /^\//s));
95 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
96 # Add the users $TERMPATH
97 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
102 $ENV{'HOME'} . '/.termcap',
104 '/usr/share/misc/termcap',
108 # return the list of those termcaps that exist
109 return grep(-f, @termcap_path);
114 Returns a blessed object reference which the user can
115 then use to send the control strings to the terminal using B<Tputs>
118 The function extracts the entry of the specified terminal
119 type I<TERM> (defaults to the environment variable I<TERM>) from the
122 It will look in the environment for a I<TERMCAP> variable. If
123 found, and the value does not begin with a slash, and the terminal
124 type name is the same as the environment string I<TERM>, the
125 I<TERMCAP> string is used instead of reading a termcap file. If
126 it does begin with a slash, the string is used as a path name of
127 the termcap file to search. If I<TERMCAP> does not begin with a
128 slash and name is different from I<TERM>, B<Tgetent> searches the
129 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
130 in that order, unless the environment variable I<TERMPATH> exists,
131 in which case it specifies a list of file pathnames (separated by
132 spaces or colons) to be searched B<instead>. Whenever multiple
133 files are searched and a tc field occurs in the requested entry,
134 the entry it names must be found in the same file or one of the
135 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
136 environment variable string it will continue the search in the
139 The extracted termcap entry is available in the object
140 as C<$self-E<gt>{TERMCAP}>.
142 It takes a hash reference as an argument with two optional keys:
148 The terminal output bit rate (often mistakenly called the baud rate)
149 for this terminal - if not set a warning will be generated
150 and it will be defaulted to 9600. I<OSPEED> can be be specified as
151 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
152 an old DSD-style speed ( where 13 equals 9600).
157 The terminal type whose termcap entry will be used - if not supplied it will
158 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
162 It calls C<croak> on failure.
166 sub Tgetent { ## public -- static method
170 $self = {} unless defined $self;
173 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
174 local($termpat,$state,$first,$entry); # used inside eval
177 # Compute PADDING factor from OSPEED (to be used by Tpad)
178 if (! $self->{OSPEED}) {
180 carp "OSPEED was not set, defaulting to 9600";
182 $self->{OSPEED} = 9600;
184 if ($self->{OSPEED} < 16) {
185 # delays for old style speeds
186 my @pad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
187 $self->{PADDING} = $pad[$self->{OSPEED}];
190 $self->{PADDING} = 10000 / $self->{OSPEED};
193 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
194 $term = $self->{TERM}; # $term is the term type we are looking for
196 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
197 $tmp_term = $self->{TERM};
198 # protect any pattern metacharacters in $tmp_term
199 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
201 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
203 # $entry is the extracted termcap entry
204 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
208 my @termcap_path = termcap_path();
210 unless (@termcap_path || $entry)
212 # last resort--fake up a termcap from terminfo
213 local $ENV{TERM} = $term;
215 if ( $^O eq 'VMS' ) {
216 $entry = $VMS_TERMCAP;
219 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) {
222 my $tmp = `infocmp -C 2>/dev/null`;
224 if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) {
232 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
234 $state = 1; # 0 == finished
238 $first = 0; # first entry (keeps term name)
240 $max = 32; # max :tc=...:'s
243 # ok, we're starting with $TERMCAP
244 $first++; # we're the first entry
245 # do we need to continue?
246 if ($entry =~ s/:tc=([^:]+):/:/) {
248 # protect any pattern metacharacters in $tmp_term
249 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
252 $state = 0; # we're already finished
256 # This is eval'ed inside the while loop for each file
259 next if /^\\t/ || /^#/;
260 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
262 s/^[^:]*:// if $first++;
264 while ($_ =~ s/\\\\$//) {
265 defined(my $x = <TERMCAP>) or last;
271 defined $entry or $entry = '';
275 while ($state != 0) {
277 # get the next TERMCAP
278 $TERMCAP = shift @termcap_path
279 || croak "failed termcap lookup on $tmp_term";
282 # do the same file again
283 # prevent endless recursion
284 $max-- || croak "failed termcap loop at $tmp_term";
285 $state = 1; # ok, maybe do a new file next time
288 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
293 # If :tc=...: found then search this file again
294 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
295 # protect any pattern metacharacters in $tmp_term
296 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
299 croak "Can't find $term" if $entry eq '';
300 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
301 $entry =~ s/:+/:/g; # cleanup $entry
302 $self->{TERMCAP} = $entry; # save it
303 # print STDERR "DEBUG: $entry = ", $entry, "\n";
305 # Precompile $entry into the object
306 $entry =~ s/^[^:]*://;
307 foreach $field (split(/:[\s:\\]*/,$entry)) {
308 if (defined $field && $field =~ /^(\w\w)$/) {
309 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
310 # print STDERR "DEBUG: flag $1\n";
312 elsif (defined $field && $field =~ /^(\w\w)\@/) {
313 $self->{'_' . $1} = "";
314 # print STDERR "DEBUG: unset $1\n";
316 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
317 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
318 # print STDERR "DEBUG: numeric $1 = $2\n";
320 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
321 # print STDERR "DEBUG: string $1 = $2\n";
322 next if defined $self->{'_' . ($cap = $1)};
325 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
333 s/\^(.)/pack('c',ord($1) & 31)/eg;
336 $self->{'_' . $cap} = $_;
338 # else { carp "junk in $term ignored: $field"; }
340 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
341 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
345 # $terminal->Tpad($string, $cnt, $FH);
349 Outputs a literal string with appropriate padding for the current terminal.
351 It takes three arguments:
357 The literal string to be output. If it starts with a number and an optional
358 '*' then the padding will be increased by an amount relative to this number,
359 if the '*' is present then this amount will me multiplied by $cnt. This part
360 of $string is removed before output/
364 Will be used to modify the padding applied to string as described above.
368 An optional filehandle (or IO::Handle ) that output will be printed to.
372 The padded $string is returned.
378 my($string, $cnt, $FH) = @_;
381 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
385 $decr = $self->{PADDING};
388 $string .= $self->{'_pc'} x ($ms / $decr);
391 print $FH $string if $FH;
395 # $terminal->Tputs($cap, $cnt, $FH);
399 Output the string for the given capability padded as appropriate without
400 any parameter substitution.
402 It takes three arguments:
408 The capability whose string is to be output.
412 A count passed to Tpad to modify the padding applied to the output string.
413 If $cnt is zero or one then the resulting string will be cached.
417 An optional filehandle (or IO::Handle ) that output will be printed to.
421 The appropriate string for the capability will be returned.
425 sub Tputs { ## public
427 my($cap, $cnt, $FH) = @_;
430 $cnt = 0 unless $cnt;
433 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
435 # cache result because Tpad can be slow
436 unless (exists $self->{$cap}) {
437 $self->{$cap} = exists $self->{"_$cap"} ?
438 Tpad($self, $self->{"_$cap"}, 1) : undef;
440 $string = $self->{$cap};
442 print $FH $string if $FH;
446 # $terminal->Tgoto($cap, $col, $row, $FH);
450 B<Tgoto> decodes a cursor addressing string with the given parameters.
452 There are four arguments:
458 The name of the capability to be output.
462 The first value to be substituted in the output string ( usually the column
463 in a cursor addressing capability )
467 The second value to be substituted in the output string (usually the row
468 in cursor addressing capabilities)
472 An optional filehandle (or IO::Handle ) to which the output string will be
477 Substitutions are made with $col and $row in the output string with the
478 following sprintf() line formats:
481 %d output value as in printf %d
482 %2 output value as in printf %2d
483 %3 output value as in printf %3d
484 %. output value as in printf %c
485 %+x add x to value, then do %.
487 %>xy if value > x then add y, no output
488 %r reverse order of two parameters, no output
489 %i increment by one, no output
490 %B BCD (16*(value/10)) + (value%10), no output
492 %n exclusive-or all parameters with 0140 (Datamedia 2500)
493 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
495 The output string will be returned.
499 sub Tgoto { ## public
501 my($cap, $code, $tmp, $FH) = @_;
502 my $string = $self->{'_' . $cap};
506 my @tmp = ($tmp,$code);
509 while ($string =~ /^([^%]*)%(.)(.*)/) {
514 $result .= sprintf("%d",shift(@tmp));
516 elsif ($code eq '.') {
518 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
520 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
523 ++$tmp, $after .= $self->{'_bc'};
526 $result .= sprintf("%c",$tmp);
529 elsif ($code eq '+') {
530 $result .= sprintf("%c",shift(@tmp)+ord($string));
531 $string = substr($string,1,99);
534 elsif ($code eq 'r') {
539 elsif ($code eq '>') {
540 ($code,$tmp,$string) = unpack("CCa99",$string);
541 if ($tmp[$[] > $code) {
545 elsif ($code eq '2') {
546 $result .= sprintf("%02d",shift(@tmp));
549 elsif ($code eq '3') {
550 $result .= sprintf("%03d",shift(@tmp));
553 elsif ($code eq 'i') {
555 @tmp = ($code+1,$tmp+1);
561 $string = Tpad($self, $result . $string . $after, $cnt);
562 print $FH $string if $FH;
566 # $terminal->Trequire(qw/ce ku kd/);
570 Takes a list of capabilities as an argument and will croak if one is not
575 sub Trequire { ## public
579 push(@undefined, $cap)
580 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
582 croak "Terminal does not support: (@undefined)" if @undefined;
591 # Get terminal output speed
593 my $termios = new POSIX::Termios;
595 my $ospeed = $termios->getospeed;
597 # Old-style ioctl code to get ospeed:
598 # require 'ioctl.pl';
599 # ioctl(TTY,$TIOCGETP,$sgtty);
600 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
602 # allocate and initialize a terminal structure
603 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
605 # require certain capabilities to be available
606 $terminal->Trequire(qw/ce ku kd/);
608 # Output Routines, if $FH is undefined these just return the string
610 # Tgoto does the % expansion stuff with the given args
611 $terminal->Tgoto('cm', $col, $row, $FH);
613 # Tputs doesn't do any % expansion.
614 $terminal->Tputs('dl', $count = 1, $FH);
616 =head1 COPYRIGHT AND LICENSE
618 Please see the README file in distribution.
622 This module is part of the core Perl distribution and is also maintained
623 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
631 # Below is a default entry for systems where there are terminals but no
635 vt220|vt200|DEC VT220 in vt100 emulation mode:
639 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
640 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
641 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
642 ei=\E[4l:ho=\E[H:im=\E[4h:
645 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
646 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
648 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
649 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
650 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: