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
32 # Version 1.08: Fri Aug 30 14:15:55 CEST 2002
33 # Cope with comments lines from 'infocmp' from Brendan O'Dea
36 # support Berkeley DB termcaps
37 # should probably be a .xs module
38 # force $FH into callers package?
39 # keep $FH in object at Tgetent time?
43 Term::Cap - Perl termcap interface
48 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
49 $terminal->Trequire(qw/ce ku kd/);
50 $terminal->Tgoto('cm', $col, $row, $FH);
51 $terminal->Tputs('dl', $count, $FH);
52 $terminal->Tpad($string, $count, $FH);
56 These are low-level functions to extract and use capabilities from
57 a terminal capability (termcap) database.
59 More information on the terminal capabilities will be found in the
60 termcap manpage on most Unix-like systems.
66 The output strings for B<Tputs> are cached for counts of 1 for performance.
67 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
68 data and C<$self-E<gt>{xx}> is the cached version.
70 print $terminal->Tpad($self->{_xx}, 1);
72 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
73 output the string to $FH if specified.
78 # Preload the default VMS termcap.
79 # If a different termcap is required then the text of one can be supplied
80 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
83 chomp (my @entry = <DATA>);
84 $VMS_TERMCAP = join '', @entry;
87 # Returns a list of termcap files to check.
89 sub termcap_path { ## private
91 # $TERMCAP, if it's a filespec
92 push(@termcap_path, $ENV{TERMCAP})
93 if ((exists $ENV{TERMCAP}) &&
94 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
95 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
96 : $ENV{TERMCAP} =~ /^\//s));
97 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
98 # Add the users $TERMPATH
99 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
104 $ENV{'HOME'} . '/.termcap',
106 '/usr/share/misc/termcap',
110 # return the list of those termcaps that exist
111 return grep(-f, @termcap_path);
116 Returns a blessed object reference which the user can
117 then use to send the control strings to the terminal using B<Tputs>
120 The function extracts the entry of the specified terminal
121 type I<TERM> (defaults to the environment variable I<TERM>) from the
124 It will look in the environment for a I<TERMCAP> variable. If
125 found, and the value does not begin with a slash, and the terminal
126 type name is the same as the environment string I<TERM>, the
127 I<TERMCAP> string is used instead of reading a termcap file. If
128 it does begin with a slash, the string is used as a path name of
129 the termcap file to search. If I<TERMCAP> does not begin with a
130 slash and name is different from I<TERM>, B<Tgetent> searches the
131 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
132 in that order, unless the environment variable I<TERMPATH> exists,
133 in which case it specifies a list of file pathnames (separated by
134 spaces or colons) to be searched B<instead>. Whenever multiple
135 files are searched and a tc field occurs in the requested entry,
136 the entry it names must be found in the same file or one of the
137 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
138 environment variable string it will continue the search in the
141 The extracted termcap entry is available in the object
142 as C<$self-E<gt>{TERMCAP}>.
144 It takes a hash reference as an argument with two optional keys:
150 The terminal output bit rate (often mistakenly called the baud rate)
151 for this terminal - if not set a warning will be generated
152 and it will be defaulted to 9600. I<OSPEED> can be be specified as
153 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
154 an old DSD-style speed ( where 13 equals 9600).
159 The terminal type whose termcap entry will be used - if not supplied it will
160 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
164 It calls C<croak> on failure.
168 sub Tgetent { ## public -- static method
172 $self = {} unless defined $self;
175 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
176 local($termpat,$state,$first,$entry); # used inside eval
179 # Compute PADDING factor from OSPEED (to be used by Tpad)
180 if (! $self->{OSPEED}) {
182 carp "OSPEED was not set, defaulting to 9600";
184 $self->{OSPEED} = 9600;
186 if ($self->{OSPEED} < 16) {
187 # delays for old style speeds
188 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);
189 $self->{PADDING} = $pad[$self->{OSPEED}];
192 $self->{PADDING} = 10000 / $self->{OSPEED};
195 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
196 $term = $self->{TERM}; # $term is the term type we are looking for
198 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
199 $tmp_term = $self->{TERM};
200 # protect any pattern metacharacters in $tmp_term
201 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
203 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
205 # $entry is the extracted termcap entry
206 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
210 my @termcap_path = termcap_path();
212 unless (@termcap_path || $entry)
214 # last resort--fake up a termcap from terminfo
215 local $ENV{TERM} = $term;
217 if ( $^O eq 'VMS' ) {
218 $entry = $VMS_TERMCAP;
221 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) {
223 my $tmp = `infocmp -C 2>/dev/null`;
224 $tmp =~ s/^#.*\n//gm; # remove comments
226 if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) {
234 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
236 $state = 1; # 0 == finished
240 $first = 0; # first entry (keeps term name)
242 $max = 32; # max :tc=...:'s
245 # ok, we're starting with $TERMCAP
246 $first++; # we're the first entry
247 # do we need to continue?
248 if ($entry =~ s/:tc=([^:]+):/:/) {
250 # protect any pattern metacharacters in $tmp_term
251 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
254 $state = 0; # we're already finished
258 # This is eval'ed inside the while loop for each file
261 next if /^\\t/ || /^#/;
262 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
264 s/^[^:]*:// if $first++;
266 while ($_ =~ s/\\\\$//) {
267 defined(my $x = <TERMCAP>) or last;
273 defined $entry or $entry = '';
277 while ($state != 0) {
279 # get the next TERMCAP
280 $TERMCAP = shift @termcap_path
281 || croak "failed termcap lookup on $tmp_term";
284 # do the same file again
285 # prevent endless recursion
286 $max-- || croak "failed termcap loop at $tmp_term";
287 $state = 1; # ok, maybe do a new file next time
290 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
295 # If :tc=...: found then search this file again
296 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
297 # protect any pattern metacharacters in $tmp_term
298 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
301 croak "Can't find $term" if $entry eq '';
302 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
303 $entry =~ s/:+/:/g; # cleanup $entry
304 $self->{TERMCAP} = $entry; # save it
305 # print STDERR "DEBUG: $entry = ", $entry, "\n";
307 # Precompile $entry into the object
308 $entry =~ s/^[^:]*://;
309 foreach $field (split(/:[\s:\\]*/,$entry)) {
310 if (defined $field && $field =~ /^(\w\w)$/) {
311 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
312 # print STDERR "DEBUG: flag $1\n";
314 elsif (defined $field && $field =~ /^(\w\w)\@/) {
315 $self->{'_' . $1} = "";
316 # print STDERR "DEBUG: unset $1\n";
318 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
319 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
320 # print STDERR "DEBUG: numeric $1 = $2\n";
322 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
323 # print STDERR "DEBUG: string $1 = $2\n";
324 next if defined $self->{'_' . ($cap = $1)};
327 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
335 s/\^(.)/pack('c',ord($1) & 31)/eg;
338 $self->{'_' . $cap} = $_;
340 # else { carp "junk in $term ignored: $field"; }
342 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
343 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
347 # $terminal->Tpad($string, $cnt, $FH);
351 Outputs a literal string with appropriate padding for the current terminal.
353 It takes three arguments:
359 The literal string to be output. If it starts with a number and an optional
360 '*' then the padding will be increased by an amount relative to this number,
361 if the '*' is present then this amount will me multiplied by $cnt. This part
362 of $string is removed before output/
366 Will be used to modify the padding applied to string as described above.
370 An optional filehandle (or IO::Handle ) that output will be printed to.
374 The padded $string is returned.
380 my($string, $cnt, $FH) = @_;
383 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
387 $decr = $self->{PADDING};
390 $string .= $self->{'_pc'} x ($ms / $decr);
393 print $FH $string if $FH;
397 # $terminal->Tputs($cap, $cnt, $FH);
401 Output the string for the given capability padded as appropriate without
402 any parameter substitution.
404 It takes three arguments:
410 The capability whose string is to be output.
414 A count passed to Tpad to modify the padding applied to the output string.
415 If $cnt is zero or one then the resulting string will be cached.
419 An optional filehandle (or IO::Handle ) that output will be printed to.
423 The appropriate string for the capability will be returned.
427 sub Tputs { ## public
429 my($cap, $cnt, $FH) = @_;
432 $cnt = 0 unless $cnt;
435 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
437 # cache result because Tpad can be slow
438 unless (exists $self->{$cap}) {
439 $self->{$cap} = exists $self->{"_$cap"} ?
440 Tpad($self, $self->{"_$cap"}, 1) : undef;
442 $string = $self->{$cap};
444 print $FH $string if $FH;
448 # $terminal->Tgoto($cap, $col, $row, $FH);
452 B<Tgoto> decodes a cursor addressing string with the given parameters.
454 There are four arguments:
460 The name of the capability to be output.
464 The first value to be substituted in the output string ( usually the column
465 in a cursor addressing capability )
469 The second value to be substituted in the output string (usually the row
470 in cursor addressing capabilities)
474 An optional filehandle (or IO::Handle ) to which the output string will be
479 Substitutions are made with $col and $row in the output string with the
480 following sprintf() line formats:
483 %d output value as in printf %d
484 %2 output value as in printf %2d
485 %3 output value as in printf %3d
486 %. output value as in printf %c
487 %+x add x to value, then do %.
489 %>xy if value > x then add y, no output
490 %r reverse order of two parameters, no output
491 %i increment by one, no output
492 %B BCD (16*(value/10)) + (value%10), no output
494 %n exclusive-or all parameters with 0140 (Datamedia 2500)
495 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
497 The output string will be returned.
501 sub Tgoto { ## public
503 my($cap, $code, $tmp, $FH) = @_;
504 my $string = $self->{'_' . $cap};
508 my @tmp = ($tmp,$code);
511 while ($string =~ /^([^%]*)%(.)(.*)/) {
516 $result .= sprintf("%d",shift(@tmp));
518 elsif ($code eq '.') {
520 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
522 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
525 ++$tmp, $after .= $self->{'_bc'};
528 $result .= sprintf("%c",$tmp);
531 elsif ($code eq '+') {
532 $result .= sprintf("%c",shift(@tmp)+ord($string));
533 $string = substr($string,1,99);
536 elsif ($code eq 'r') {
541 elsif ($code eq '>') {
542 ($code,$tmp,$string) = unpack("CCa99",$string);
543 if ($tmp[$[] > $code) {
547 elsif ($code eq '2') {
548 $result .= sprintf("%02d",shift(@tmp));
551 elsif ($code eq '3') {
552 $result .= sprintf("%03d",shift(@tmp));
555 elsif ($code eq 'i') {
557 @tmp = ($code+1,$tmp+1);
563 $string = Tpad($self, $result . $string . $after, $cnt);
564 print $FH $string if $FH;
568 # $terminal->Trequire(qw/ce ku kd/);
572 Takes a list of capabilities as an argument and will croak if one is not
577 sub Trequire { ## public
581 push(@undefined, $cap)
582 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
584 croak "Terminal does not support: (@undefined)" if @undefined;
593 # Get terminal output speed
595 my $termios = new POSIX::Termios;
597 my $ospeed = $termios->getospeed;
599 # Old-style ioctl code to get ospeed:
600 # require 'ioctl.pl';
601 # ioctl(TTY,$TIOCGETP,$sgtty);
602 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
604 # allocate and initialize a terminal structure
605 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
607 # require certain capabilities to be available
608 $terminal->Trequire(qw/ce ku kd/);
610 # Output Routines, if $FH is undefined these just return the string
612 # Tgoto does the % expansion stuff with the given args
613 $terminal->Tgoto('cm', $col, $row, $FH);
615 # Tputs doesn't do any % expansion.
616 $terminal->Tputs('dl', $count = 1, $FH);
618 =head1 COPYRIGHT AND LICENSE
620 Please see the README file in distribution.
624 This module is part of the core Perl distribution and is also maintained
625 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
633 # Below is a default entry for systems where there are terminals but no
637 vt220|vt200|DEC VT220 in vt100 emulation mode:
641 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
642 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
643 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
644 ei=\E[4l:ho=\E[H:im=\E[4h:
647 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
648 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
650 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
651 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
652 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: