9 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
10 # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
11 # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
12 # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
13 # Avoid warnings in Tgetent and Tputs
14 # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
15 # Altered layout of the POD
16 # Added Test::More to PREREQ_PM in Makefile.PL
17 # Fixed no argument Tgetent()
20 # support Berkeley DB termcaps
21 # should probably be a .xs module
22 # force $FH into callers package?
23 # keep $FH in object at Tgetent time?
27 Term::Cap - Perl termcap interface
32 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
33 $terminal->Trequire(qw/ce ku kd/);
34 $terminal->Tgoto('cm', $col, $row, $FH);
35 $terminal->Tputs('dl', $count, $FH);
36 $terminal->Tpad($string, $count, $FH);
40 These are low-level functions to extract and use capabilities from
41 a terminal capability (termcap) database.
43 More information on the terminal capabilities will be found in the
44 termcap manpage on most Unix-like systems.
50 The output strings for B<Tputs> are cached for counts of 1 for performance.
51 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
52 data and C<$self-E<gt>{xx}> is the cached version.
54 print $terminal->Tpad($self->{_xx}, 1);
56 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
57 output the string to $FH if specified.
62 # Returns a list of termcap files to check.
63 sub termcap_path { ## private
65 # $TERMCAP, if it's a filespec
66 push(@termcap_path, $ENV{TERMCAP})
67 if ((exists $ENV{TERMCAP}) &&
68 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
69 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
70 : $ENV{TERMCAP} =~ /^\//s));
71 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
72 # Add the users $TERMPATH
73 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
78 $ENV{'HOME'} . '/.termcap',
80 '/usr/share/misc/termcap',
83 # return the list of those termcaps that exist
84 return grep(-f, @termcap_path);
89 Returns a blessed object reference which the user can
90 then use to send the control strings to the terminal using B<Tputs>
93 The function extracts the entry of the specified terminal
94 type I<TERM> (defaults to the environment variable I<TERM>) from the
97 It will look in the environment for a I<TERMCAP> variable. If
98 found, and the value does not begin with a slash, and the terminal
99 type name is the same as the environment string I<TERM>, the
100 I<TERMCAP> string is used instead of reading a termcap file. If
101 it does begin with a slash, the string is used as a path name of
102 the termcap file to search. If I<TERMCAP> does not begin with a
103 slash and name is different from I<TERM>, B<Tgetent> searches the
104 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
105 in that order, unless the environment variable I<TERMPATH> exists,
106 in which case it specifies a list of file pathnames (separated by
107 spaces or colons) to be searched B<instead>. Whenever multiple
108 files are searched and a tc field occurs in the requested entry,
109 the entry it names must be found in the same file or one of the
110 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
111 environment variable string it will continue the search in the
114 The extracted termcap entry is available in the object
115 as C<$self-E<gt>{TERMCAP}>.
117 It takes a hash reference as an argument with two optional keys:
123 The terminal output bit rate (often mistakenly called the baud rate)
124 for this terminal - if not set a warning will be generated
125 and it will be defaulted to 9600. I<OSPEED> can be be specified as
126 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
127 an old DSD-style speed ( where 13 equals 9600).
132 The terminal type whose termcap entry will be used - if not supplied it will
133 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
137 It calls C<croak> on failure.
141 sub Tgetent { ## public -- static method
145 $self = {} unless defined $self;
148 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
149 local($termpat,$state,$first,$entry); # used inside eval
152 # Compute PADDING factor from OSPEED (to be used by Tpad)
153 if (! $self->{OSPEED}) {
154 carp "OSPEED was not set, defaulting to 9600";
155 $self->{OSPEED} = 9600;
157 if ($self->{OSPEED} < 16) {
158 # delays for old style speeds
159 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);
160 $self->{PADDING} = $pad[$self->{OSPEED}];
163 $self->{PADDING} = 10000 / $self->{OSPEED};
166 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
167 $term = $self->{TERM}; # $term is the term type we are looking for
169 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
170 $tmp_term = $self->{TERM};
171 # protect any pattern metacharacters in $tmp_term
172 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
174 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
176 # $entry is the extracted termcap entry
177 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
181 my @termcap_path = termcap_path();
183 unless (@termcap_path || $entry)
185 # last resort--fake up a termcap from terminfo
186 local $ENV{TERM} = $term;
187 if ($^O eq 'VMS') { # we use REAL dec terminals, not stinkin' emulators!
188 $entry = 'vt220|vt200|DEC VT220 in vt100 emulation mode:'
191 .'RA=\E[?7l:SA=\E[?7h:'
192 .'ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:'
193 .'bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:'
194 .'cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:'
195 .'ei=\E[4l:ho=\E[H:im=\E[4h:'
196 .'is=\E[1;24r\E[24;1H:'
198 .'kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:'
199 .'mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:'
201 .'r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:'
202 .'sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:'
203 .'ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:';
207 $entry = `infocmp -C 2>/dev/null`;
212 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
214 $state = 1; # 0 == finished
218 $first = 0; # first entry (keeps term name)
220 $max = 32; # max :tc=...:'s
223 # ok, we're starting with $TERMCAP
224 $first++; # we're the first entry
225 # do we need to continue?
226 if ($entry =~ s/:tc=([^:]+):/:/) {
228 # protect any pattern metacharacters in $tmp_term
229 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
232 $state = 0; # we're already finished
236 # This is eval'ed inside the while loop for each file
239 next if /^\\t/ || /^#/;
240 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
242 s/^[^:]*:// if $first++;
244 while ($_ =~ s/\\\\$//) {
245 defined(my $x = <TERMCAP>) or last;
251 defined $entry or $entry = '';
255 while ($state != 0) {
257 # get the next TERMCAP
258 $TERMCAP = shift @termcap_path
259 || croak "failed termcap lookup on $tmp_term";
262 # do the same file again
263 # prevent endless recursion
264 $max-- || croak "failed termcap loop at $tmp_term";
265 $state = 1; # ok, maybe do a new file next time
268 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
273 # If :tc=...: found then search this file again
274 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
275 # protect any pattern metacharacters in $tmp_term
276 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
279 croak "Can't find $term" if $entry eq '';
280 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
281 $entry =~ s/:+/:/g; # cleanup $entry
282 $self->{TERMCAP} = $entry; # save it
283 # print STDERR "DEBUG: $entry = ", $entry, "\n";
285 # Precompile $entry into the object
286 $entry =~ s/^[^:]*://;
287 foreach $field (split(/:[\s:\\]*/,$entry)) {
288 if ($field =~ /^(\w\w)$/) {
289 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
290 # print STDERR "DEBUG: flag $1\n";
292 elsif ($field =~ /^(\w\w)\@/) {
293 $self->{'_' . $1} = "";
294 # print STDERR "DEBUG: unset $1\n";
296 elsif ($field =~ /^(\w\w)#(.*)/) {
297 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
298 # print STDERR "DEBUG: numeric $1 = $2\n";
300 elsif ($field =~ /^(\w\w)=(.*)/) {
301 # print STDERR "DEBUG: string $1 = $2\n";
302 next if defined $self->{'_' . ($cap = $1)};
305 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
313 s/\^(.)/pack('c',ord($1) & 31)/eg;
316 $self->{'_' . $cap} = $_;
318 # else { carp "junk in $term ignored: $field"; }
320 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
321 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
325 # $terminal->Tpad($string, $cnt, $FH);
329 Outputs a literal string with appropriate padding for the current terminal.
331 It takes three arguments:
337 The literal string to be output. If it starts with a number and an optional
338 '*' then the padding will be increased by an amount relative to this number,
339 if the '*' is present then this amount will me multiplied by $cnt. This part
340 of $string is removed before output/
344 Will be used to modify the padding applied to string as described above.
348 An optional filehandle (or IO::Handle ) that output will be printed to.
352 The padded $string is returned.
358 my($string, $cnt, $FH) = @_;
361 if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
365 $decr = $self->{PADDING};
368 $string .= $self->{'_pc'} x ($ms / $decr);
371 print $FH $string if $FH;
375 # $terminal->Tputs($cap, $cnt, $FH);
379 Output the string for the given capability padded as appropriate without
380 any parameter substitution.
382 It takes three arguments:
388 The capability whose string is to be output.
392 A count passed to Tpad to modify the padding applied to the output string.
393 If $cnt is zero or one then the resulting string will be cached.
397 An optional filehandle (or IO::Handle ) that output will be printed to.
401 The appropriate string for the capability will be returned.
405 sub Tputs { ## public
407 my($cap, $cnt, $FH) = @_;
410 $cnt = 0 unless $cnt;
413 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
415 # cache result because Tpad can be slow
416 unless (exists $self->{$cap}) {
417 $self->{$cap} = exists $self->{"_$cap"} ?
418 Tpad($self, $self->{"_$cap"}, 1) : undef;
420 $string = $self->{$cap};
422 print $FH $string if $FH;
426 # $terminal->Tgoto($cap, $col, $row, $FH);
430 B<Tgoto> decodes a cursor addressing string with the given parameters.
432 There are four arguments:
438 The name of the capability to be output.
442 The first value to be substituted in the output string ( usually the column
443 in a cursor addressing capability )
447 The second value to be substituted in the output string (usually the row
448 in cursor addressing capabilities)
452 An optional filehandle (or IO::Handle ) to which the output string will be
457 Substitutions are made with $col and $row in the output string with the
458 following sprintf() line formats:
461 %d output value as in printf %d
462 %2 output value as in printf %2d
463 %3 output value as in printf %3d
464 %. output value as in printf %c
465 %+x add x to value, then do %.
467 %>xy if value > x then add y, no output
468 %r reverse order of two parameters, no output
469 %i increment by one, no output
470 %B BCD (16*(value/10)) + (value%10), no output
472 %n exclusive-or all parameters with 0140 (Datamedia 2500)
473 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
475 The output string will be returned.
479 sub Tgoto { ## public
481 my($cap, $code, $tmp, $FH) = @_;
482 my $string = $self->{'_' . $cap};
486 my @tmp = ($tmp,$code);
489 while ($string =~ /^([^%]*)%(.)(.*)/) {
494 $result .= sprintf("%d",shift(@tmp));
496 elsif ($code eq '.') {
498 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
500 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
503 ++$tmp, $after .= $self->{'_bc'};
506 $result .= sprintf("%c",$tmp);
509 elsif ($code eq '+') {
510 $result .= sprintf("%c",shift(@tmp)+ord($string));
511 $string = substr($string,1,99);
514 elsif ($code eq 'r') {
519 elsif ($code eq '>') {
520 ($code,$tmp,$string) = unpack("CCa99",$string);
521 if ($tmp[$[] > $code) {
525 elsif ($code eq '2') {
526 $result .= sprintf("%02d",shift(@tmp));
529 elsif ($code eq '3') {
530 $result .= sprintf("%03d",shift(@tmp));
533 elsif ($code eq 'i') {
535 @tmp = ($code+1,$tmp+1);
541 $string = Tpad($self, $result . $string . $after, $cnt);
542 print $FH $string if $FH;
546 # $terminal->Trequire(qw/ce ku kd/);
550 Takes a list of capabilities as an argument and will croak if one is not
555 sub Trequire { ## public
559 push(@undefined, $cap)
560 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
562 croak "Terminal does not support: (@undefined)" if @undefined;
574 # Get terminal output speed
576 my $termios = new POSIX::Termios;
578 my $ospeed = $termios->getospeed;
580 # Old-style ioctl code to get ospeed:
581 # require 'ioctl.pl';
582 # ioctl(TTY,$TIOCGETP,$sgtty);
583 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
585 # allocate and initialize a terminal structure
586 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
588 # require certain capabilities to be available
589 $terminal->Trequire(qw/ce ku kd/);
591 # Output Routines, if $FH is undefined these just return the string
593 # Tgoto does the % expansion stuff with the given args
594 $terminal->Tgoto('cm', $col, $row, $FH);
596 # Tputs doesn't do any % expansion.
597 $terminal->Tputs('dl', $count = 1, $FH);
599 =head1 COPYRIGHT AND LICENSE
601 Please see the README file in distribution.
605 This module is part of the core Perl distribution and is also maintained
606 for CPAN by Jonathan Stowe <jns@gellyfish.com>.