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.
31 # support Berkeley DB termcaps
32 # should probably be a .xs module
33 # force $FH into callers package?
34 # keep $FH in object at Tgetent time?
38 Term::Cap - Perl termcap interface
43 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
44 $terminal->Trequire(qw/ce ku kd/);
45 $terminal->Tgoto('cm', $col, $row, $FH);
46 $terminal->Tputs('dl', $count, $FH);
47 $terminal->Tpad($string, $count, $FH);
51 These are low-level functions to extract and use capabilities from
52 a terminal capability (termcap) database.
54 More information on the terminal capabilities will be found in the
55 termcap manpage on most Unix-like systems.
61 The output strings for B<Tputs> are cached for counts of 1 for performance.
62 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
63 data and C<$self-E<gt>{xx}> is the cached version.
65 print $terminal->Tpad($self->{_xx}, 1);
67 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
68 output the string to $FH if specified.
73 # Preload the default VMS termcap.
74 # If a different termcap is required then the text of one can be supplied
75 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
78 chomp (my @entry = <DATA>);
79 $VMS_TERMCAP = join '', @entry;
82 # Returns a list of termcap files to check.
84 sub termcap_path { ## private
86 # $TERMCAP, if it's a filespec
87 push(@termcap_path, $ENV{TERMCAP})
88 if ((exists $ENV{TERMCAP}) &&
89 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
90 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
91 : $ENV{TERMCAP} =~ /^\//s));
92 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
93 # Add the users $TERMPATH
94 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
99 $ENV{'HOME'} . '/.termcap',
101 '/usr/share/misc/termcap',
105 # return the list of those termcaps that exist
106 return grep(-f, @termcap_path);
111 Returns a blessed object reference which the user can
112 then use to send the control strings to the terminal using B<Tputs>
115 The function extracts the entry of the specified terminal
116 type I<TERM> (defaults to the environment variable I<TERM>) from the
119 It will look in the environment for a I<TERMCAP> variable. If
120 found, and the value does not begin with a slash, and the terminal
121 type name is the same as the environment string I<TERM>, the
122 I<TERMCAP> string is used instead of reading a termcap file. If
123 it does begin with a slash, the string is used as a path name of
124 the termcap file to search. If I<TERMCAP> does not begin with a
125 slash and name is different from I<TERM>, B<Tgetent> searches the
126 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
127 in that order, unless the environment variable I<TERMPATH> exists,
128 in which case it specifies a list of file pathnames (separated by
129 spaces or colons) to be searched B<instead>. Whenever multiple
130 files are searched and a tc field occurs in the requested entry,
131 the entry it names must be found in the same file or one of the
132 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
133 environment variable string it will continue the search in the
136 The extracted termcap entry is available in the object
137 as C<$self-E<gt>{TERMCAP}>.
139 It takes a hash reference as an argument with two optional keys:
145 The terminal output bit rate (often mistakenly called the baud rate)
146 for this terminal - if not set a warning will be generated
147 and it will be defaulted to 9600. I<OSPEED> can be be specified as
148 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
149 an old DSD-style speed ( where 13 equals 9600).
154 The terminal type whose termcap entry will be used - if not supplied it will
155 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
159 It calls C<croak> on failure.
163 sub Tgetent { ## public -- static method
167 $self = {} unless defined $self;
170 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
171 local($termpat,$state,$first,$entry); # used inside eval
174 # Compute PADDING factor from OSPEED (to be used by Tpad)
175 if (! $self->{OSPEED}) {
177 carp "OSPEED was not set, defaulting to 9600";
179 $self->{OSPEED} = 9600;
181 if ($self->{OSPEED} < 16) {
182 # delays for old style speeds
183 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);
184 $self->{PADDING} = $pad[$self->{OSPEED}];
187 $self->{PADDING} = 10000 / $self->{OSPEED};
190 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
191 $term = $self->{TERM}; # $term is the term type we are looking for
193 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
194 $tmp_term = $self->{TERM};
195 # protect any pattern metacharacters in $tmp_term
196 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
198 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
200 # $entry is the extracted termcap entry
201 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
205 my @termcap_path = termcap_path();
207 unless (@termcap_path || $entry)
209 # last resort--fake up a termcap from terminfo
210 local $ENV{TERM} = $term;
212 if ( $^O eq 'VMS' ) {
213 $entry = $VMS_TERMCAP;
218 $entry = `infocmp -C 2>/dev/null`
219 if grep { -x "$_/infocmp" } split /:/, $ENV{PATH};
224 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
226 $state = 1; # 0 == finished
230 $first = 0; # first entry (keeps term name)
232 $max = 32; # max :tc=...:'s
235 # ok, we're starting with $TERMCAP
236 $first++; # we're the first entry
237 # do we need to continue?
238 if ($entry =~ s/:tc=([^:]+):/:/) {
240 # protect any pattern metacharacters in $tmp_term
241 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
244 $state = 0; # we're already finished
248 # This is eval'ed inside the while loop for each file
251 next if /^\\t/ || /^#/;
252 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
254 s/^[^:]*:// if $first++;
256 while ($_ =~ s/\\\\$//) {
257 defined(my $x = <TERMCAP>) or last;
263 defined $entry or $entry = '';
267 while ($state != 0) {
269 # get the next TERMCAP
270 $TERMCAP = shift @termcap_path
271 || croak "failed termcap lookup on $tmp_term";
274 # do the same file again
275 # prevent endless recursion
276 $max-- || croak "failed termcap loop at $tmp_term";
277 $state = 1; # ok, maybe do a new file next time
280 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
285 # If :tc=...: found then search this file again
286 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
287 # protect any pattern metacharacters in $tmp_term
288 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
291 croak "Can't find $term" if $entry eq '';
292 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
293 $entry =~ s/:+/:/g; # cleanup $entry
294 $self->{TERMCAP} = $entry; # save it
295 # print STDERR "DEBUG: $entry = ", $entry, "\n";
297 # Precompile $entry into the object
298 $entry =~ s/^[^:]*://;
299 foreach $field (split(/:[\s:\\]*/,$entry)) {
300 if (defined $field && $field =~ /^(\w\w)$/) {
301 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
302 # print STDERR "DEBUG: flag $1\n";
304 elsif (defined $field && $field =~ /^(\w\w)\@/) {
305 $self->{'_' . $1} = "";
306 # print STDERR "DEBUG: unset $1\n";
308 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
309 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
310 # print STDERR "DEBUG: numeric $1 = $2\n";
312 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
313 # print STDERR "DEBUG: string $1 = $2\n";
314 next if defined $self->{'_' . ($cap = $1)};
317 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
325 s/\^(.)/pack('c',ord($1) & 31)/eg;
328 $self->{'_' . $cap} = $_;
330 # else { carp "junk in $term ignored: $field"; }
332 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
333 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
337 # $terminal->Tpad($string, $cnt, $FH);
341 Outputs a literal string with appropriate padding for the current terminal.
343 It takes three arguments:
349 The literal string to be output. If it starts with a number and an optional
350 '*' then the padding will be increased by an amount relative to this number,
351 if the '*' is present then this amount will me multiplied by $cnt. This part
352 of $string is removed before output/
356 Will be used to modify the padding applied to string as described above.
360 An optional filehandle (or IO::Handle ) that output will be printed to.
364 The padded $string is returned.
370 my($string, $cnt, $FH) = @_;
373 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
377 $decr = $self->{PADDING};
380 $string .= $self->{'_pc'} x ($ms / $decr);
383 print $FH $string if $FH;
387 # $terminal->Tputs($cap, $cnt, $FH);
391 Output the string for the given capability padded as appropriate without
392 any parameter substitution.
394 It takes three arguments:
400 The capability whose string is to be output.
404 A count passed to Tpad to modify the padding applied to the output string.
405 If $cnt is zero or one then the resulting string will be cached.
409 An optional filehandle (or IO::Handle ) that output will be printed to.
413 The appropriate string for the capability will be returned.
417 sub Tputs { ## public
419 my($cap, $cnt, $FH) = @_;
422 $cnt = 0 unless $cnt;
425 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
427 # cache result because Tpad can be slow
428 unless (exists $self->{$cap}) {
429 $self->{$cap} = exists $self->{"_$cap"} ?
430 Tpad($self, $self->{"_$cap"}, 1) : undef;
432 $string = $self->{$cap};
434 print $FH $string if $FH;
438 # $terminal->Tgoto($cap, $col, $row, $FH);
442 B<Tgoto> decodes a cursor addressing string with the given parameters.
444 There are four arguments:
450 The name of the capability to be output.
454 The first value to be substituted in the output string ( usually the column
455 in a cursor addressing capability )
459 The second value to be substituted in the output string (usually the row
460 in cursor addressing capabilities)
464 An optional filehandle (or IO::Handle ) to which the output string will be
469 Substitutions are made with $col and $row in the output string with the
470 following sprintf() line formats:
473 %d output value as in printf %d
474 %2 output value as in printf %2d
475 %3 output value as in printf %3d
476 %. output value as in printf %c
477 %+x add x to value, then do %.
479 %>xy if value > x then add y, no output
480 %r reverse order of two parameters, no output
481 %i increment by one, no output
482 %B BCD (16*(value/10)) + (value%10), no output
484 %n exclusive-or all parameters with 0140 (Datamedia 2500)
485 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
487 The output string will be returned.
491 sub Tgoto { ## public
493 my($cap, $code, $tmp, $FH) = @_;
494 my $string = $self->{'_' . $cap};
498 my @tmp = ($tmp,$code);
501 while ($string =~ /^([^%]*)%(.)(.*)/) {
506 $result .= sprintf("%d",shift(@tmp));
508 elsif ($code eq '.') {
510 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
512 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
515 ++$tmp, $after .= $self->{'_bc'};
518 $result .= sprintf("%c",$tmp);
521 elsif ($code eq '+') {
522 $result .= sprintf("%c",shift(@tmp)+ord($string));
523 $string = substr($string,1,99);
526 elsif ($code eq 'r') {
531 elsif ($code eq '>') {
532 ($code,$tmp,$string) = unpack("CCa99",$string);
533 if ($tmp[$[] > $code) {
537 elsif ($code eq '2') {
538 $result .= sprintf("%02d",shift(@tmp));
541 elsif ($code eq '3') {
542 $result .= sprintf("%03d",shift(@tmp));
545 elsif ($code eq 'i') {
547 @tmp = ($code+1,$tmp+1);
553 $string = Tpad($self, $result . $string . $after, $cnt);
554 print $FH $string if $FH;
558 # $terminal->Trequire(qw/ce ku kd/);
562 Takes a list of capabilities as an argument and will croak if one is not
567 sub Trequire { ## public
571 push(@undefined, $cap)
572 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
574 croak "Terminal does not support: (@undefined)" if @undefined;
583 # Get terminal output speed
585 my $termios = new POSIX::Termios;
587 my $ospeed = $termios->getospeed;
589 # Old-style ioctl code to get ospeed:
590 # require 'ioctl.pl';
591 # ioctl(TTY,$TIOCGETP,$sgtty);
592 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
594 # allocate and initialize a terminal structure
595 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
597 # require certain capabilities to be available
598 $terminal->Trequire(qw/ce ku kd/);
600 # Output Routines, if $FH is undefined these just return the string
602 # Tgoto does the % expansion stuff with the given args
603 $terminal->Tgoto('cm', $col, $row, $FH);
605 # Tputs doesn't do any % expansion.
606 $terminal->Tputs('dl', $count = 1, $FH);
608 =head1 COPYRIGHT AND LICENSE
610 Please see the README file in distribution.
614 This module is part of the core Perl distribution and is also maintained
615 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
623 # Below is a default entry for systems where there are terminals but no
627 vt220|vt200|DEC VT220 in vt100 emulation mode:
631 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
632 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
633 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
634 ei=\E[4l:ho=\E[H:im=\E[4h:
637 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
638 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
640 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
641 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
642 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: