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()
18 # Version 1.03: Wed Nov 28 10:09:38 GMT 2001
19 # VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
22 # support Berkeley DB termcaps
23 # should probably be a .xs module
24 # force $FH into callers package?
25 # keep $FH in object at Tgetent time?
29 Term::Cap - Perl termcap interface
34 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
35 $terminal->Trequire(qw/ce ku kd/);
36 $terminal->Tgoto('cm', $col, $row, $FH);
37 $terminal->Tputs('dl', $count, $FH);
38 $terminal->Tpad($string, $count, $FH);
42 These are low-level functions to extract and use capabilities from
43 a terminal capability (termcap) database.
45 More information on the terminal capabilities will be found in the
46 termcap manpage on most Unix-like systems.
52 The output strings for B<Tputs> are cached for counts of 1 for performance.
53 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
54 data and C<$self-E<gt>{xx}> is the cached version.
56 print $terminal->Tpad($self->{_xx}, 1);
58 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
59 output the string to $FH if specified.
64 # Returns a list of termcap files to check.
65 sub termcap_path { ## private
67 # $TERMCAP, if it's a filespec
68 push(@termcap_path, $ENV{TERMCAP})
69 if ((exists $ENV{TERMCAP}) &&
70 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
71 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
72 : $ENV{TERMCAP} =~ /^\//s));
73 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
74 # Add the users $TERMPATH
75 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
80 $ENV{'HOME'} . '/.termcap',
82 '/usr/share/misc/termcap',
85 # return the list of those termcaps that exist
86 return grep(-f, @termcap_path);
91 Returns a blessed object reference which the user can
92 then use to send the control strings to the terminal using B<Tputs>
95 The function extracts the entry of the specified terminal
96 type I<TERM> (defaults to the environment variable I<TERM>) from the
99 It will look in the environment for a I<TERMCAP> variable. If
100 found, and the value does not begin with a slash, and the terminal
101 type name is the same as the environment string I<TERM>, the
102 I<TERMCAP> string is used instead of reading a termcap file. If
103 it does begin with a slash, the string is used as a path name of
104 the termcap file to search. If I<TERMCAP> does not begin with a
105 slash and name is different from I<TERM>, B<Tgetent> searches the
106 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
107 in that order, unless the environment variable I<TERMPATH> exists,
108 in which case it specifies a list of file pathnames (separated by
109 spaces or colons) to be searched B<instead>. Whenever multiple
110 files are searched and a tc field occurs in the requested entry,
111 the entry it names must be found in the same file or one of the
112 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
113 environment variable string it will continue the search in the
116 The extracted termcap entry is available in the object
117 as C<$self-E<gt>{TERMCAP}>.
119 It takes a hash reference as an argument with two optional keys:
125 The terminal output bit rate (often mistakenly called the baud rate)
126 for this terminal - if not set a warning will be generated
127 and it will be defaulted to 9600. I<OSPEED> can be be specified as
128 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
129 an old DSD-style speed ( where 13 equals 9600).
134 The terminal type whose termcap entry will be used - if not supplied it will
135 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
139 It calls C<croak> on failure.
143 sub Tgetent { ## public -- static method
147 $self = {} unless defined $self;
150 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
151 local($termpat,$state,$first,$entry); # used inside eval
154 # Compute PADDING factor from OSPEED (to be used by Tpad)
155 if (! $self->{OSPEED}) {
156 carp "OSPEED was not set, defaulting to 9600";
157 $self->{OSPEED} = 9600;
159 if ($self->{OSPEED} < 16) {
160 # delays for old style speeds
161 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);
162 $self->{PADDING} = $pad[$self->{OSPEED}];
165 $self->{PADDING} = 10000 / $self->{OSPEED};
168 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
169 $term = $self->{TERM}; # $term is the term type we are looking for
171 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
172 $tmp_term = $self->{TERM};
173 # protect any pattern metacharacters in $tmp_term
174 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
176 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
178 # $entry is the extracted termcap entry
179 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
183 my @termcap_path = termcap_path();
185 unless (@termcap_path || $entry)
187 # last resort--fake up a termcap from terminfo
188 local $ENV{TERM} = $term;
190 if ( $^O eq 'VMS' ) {
191 chomp(my @entry = <DATA>);
192 $entry = join '', @entry;
197 $entry = `infocmp -C 2>/dev/null`;
203 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
205 $state = 1; # 0 == finished
209 $first = 0; # first entry (keeps term name)
211 $max = 32; # max :tc=...:'s
214 # ok, we're starting with $TERMCAP
215 $first++; # we're the first entry
216 # do we need to continue?
217 if ($entry =~ s/:tc=([^:]+):/:/) {
219 # protect any pattern metacharacters in $tmp_term
220 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
223 $state = 0; # we're already finished
227 # This is eval'ed inside the while loop for each file
230 next if /^\\t/ || /^#/;
231 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
233 s/^[^:]*:// if $first++;
235 while ($_ =~ s/\\\\$//) {
236 defined(my $x = <TERMCAP>) or last;
242 defined $entry or $entry = '';
246 while ($state != 0) {
248 # get the next TERMCAP
249 $TERMCAP = shift @termcap_path
250 || croak "failed termcap lookup on $tmp_term";
253 # do the same file again
254 # prevent endless recursion
255 $max-- || croak "failed termcap loop at $tmp_term";
256 $state = 1; # ok, maybe do a new file next time
259 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
264 # If :tc=...: found then search this file again
265 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
266 # protect any pattern metacharacters in $tmp_term
267 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
270 croak "Can't find $term" if $entry eq '';
271 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
272 $entry =~ s/:+/:/g; # cleanup $entry
273 $self->{TERMCAP} = $entry; # save it
274 # print STDERR "DEBUG: $entry = ", $entry, "\n";
276 # Precompile $entry into the object
277 $entry =~ s/^[^:]*://;
278 foreach $field (split(/:[\s:\\]*/,$entry)) {
279 if ($field =~ /^(\w\w)$/) {
280 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
281 # print STDERR "DEBUG: flag $1\n";
283 elsif ($field =~ /^(\w\w)\@/) {
284 $self->{'_' . $1} = "";
285 # print STDERR "DEBUG: unset $1\n";
287 elsif ($field =~ /^(\w\w)#(.*)/) {
288 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
289 # print STDERR "DEBUG: numeric $1 = $2\n";
291 elsif ($field =~ /^(\w\w)=(.*)/) {
292 # print STDERR "DEBUG: string $1 = $2\n";
293 next if defined $self->{'_' . ($cap = $1)};
296 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
304 s/\^(.)/pack('c',ord($1) & 31)/eg;
307 $self->{'_' . $cap} = $_;
309 # else { carp "junk in $term ignored: $field"; }
311 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
312 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
316 # $terminal->Tpad($string, $cnt, $FH);
320 Outputs a literal string with appropriate padding for the current terminal.
322 It takes three arguments:
328 The literal string to be output. If it starts with a number and an optional
329 '*' then the padding will be increased by an amount relative to this number,
330 if the '*' is present then this amount will me multiplied by $cnt. This part
331 of $string is removed before output/
335 Will be used to modify the padding applied to string as described above.
339 An optional filehandle (or IO::Handle ) that output will be printed to.
343 The padded $string is returned.
349 my($string, $cnt, $FH) = @_;
352 if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
356 $decr = $self->{PADDING};
359 $string .= $self->{'_pc'} x ($ms / $decr);
362 print $FH $string if $FH;
366 # $terminal->Tputs($cap, $cnt, $FH);
370 Output the string for the given capability padded as appropriate without
371 any parameter substitution.
373 It takes three arguments:
379 The capability whose string is to be output.
383 A count passed to Tpad to modify the padding applied to the output string.
384 If $cnt is zero or one then the resulting string will be cached.
388 An optional filehandle (or IO::Handle ) that output will be printed to.
392 The appropriate string for the capability will be returned.
396 sub Tputs { ## public
398 my($cap, $cnt, $FH) = @_;
401 $cnt = 0 unless $cnt;
404 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
406 # cache result because Tpad can be slow
407 unless (exists $self->{$cap}) {
408 $self->{$cap} = exists $self->{"_$cap"} ?
409 Tpad($self, $self->{"_$cap"}, 1) : undef;
411 $string = $self->{$cap};
413 print $FH $string if $FH;
417 # $terminal->Tgoto($cap, $col, $row, $FH);
421 B<Tgoto> decodes a cursor addressing string with the given parameters.
423 There are four arguments:
429 The name of the capability to be output.
433 The first value to be substituted in the output string ( usually the column
434 in a cursor addressing capability )
438 The second value to be substituted in the output string (usually the row
439 in cursor addressing capabilities)
443 An optional filehandle (or IO::Handle ) to which the output string will be
448 Substitutions are made with $col and $row in the output string with the
449 following sprintf() line formats:
452 %d output value as in printf %d
453 %2 output value as in printf %2d
454 %3 output value as in printf %3d
455 %. output value as in printf %c
456 %+x add x to value, then do %.
458 %>xy if value > x then add y, no output
459 %r reverse order of two parameters, no output
460 %i increment by one, no output
461 %B BCD (16*(value/10)) + (value%10), no output
463 %n exclusive-or all parameters with 0140 (Datamedia 2500)
464 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
466 The output string will be returned.
470 sub Tgoto { ## public
472 my($cap, $code, $tmp, $FH) = @_;
473 my $string = $self->{'_' . $cap};
477 my @tmp = ($tmp,$code);
480 while ($string =~ /^([^%]*)%(.)(.*)/) {
485 $result .= sprintf("%d",shift(@tmp));
487 elsif ($code eq '.') {
489 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
491 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
494 ++$tmp, $after .= $self->{'_bc'};
497 $result .= sprintf("%c",$tmp);
500 elsif ($code eq '+') {
501 $result .= sprintf("%c",shift(@tmp)+ord($string));
502 $string = substr($string,1,99);
505 elsif ($code eq 'r') {
510 elsif ($code eq '>') {
511 ($code,$tmp,$string) = unpack("CCa99",$string);
512 if ($tmp[$[] > $code) {
516 elsif ($code eq '2') {
517 $result .= sprintf("%02d",shift(@tmp));
520 elsif ($code eq '3') {
521 $result .= sprintf("%03d",shift(@tmp));
524 elsif ($code eq 'i') {
526 @tmp = ($code+1,$tmp+1);
532 $string = Tpad($self, $result . $string . $after, $cnt);
533 print $FH $string if $FH;
537 # $terminal->Trequire(qw/ce ku kd/);
541 Takes a list of capabilities as an argument and will croak if one is not
546 sub Trequire { ## public
550 push(@undefined, $cap)
551 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
553 croak "Terminal does not support: (@undefined)" if @undefined;
562 # Get terminal output speed
564 my $termios = new POSIX::Termios;
566 my $ospeed = $termios->getospeed;
568 # Old-style ioctl code to get ospeed:
569 # require 'ioctl.pl';
570 # ioctl(TTY,$TIOCGETP,$sgtty);
571 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
573 # allocate and initialize a terminal structure
574 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
576 # require certain capabilities to be available
577 $terminal->Trequire(qw/ce ku kd/);
579 # Output Routines, if $FH is undefined these just return the string
581 # Tgoto does the % expansion stuff with the given args
582 $terminal->Tgoto('cm', $col, $row, $FH);
584 # Tputs doesn't do any % expansion.
585 $terminal->Tputs('dl', $count = 1, $FH);
587 =head1 COPYRIGHT AND LICENSE
589 Please see the README file in distribution.
593 This module is part of the core Perl distribution and is also maintained
594 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
602 # Below is a default entry for systems where there are terminals but no
606 vt220|vt200|DEC VT220 in vt100 emulation mode:
610 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
611 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
612 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
613 ei=\E[4l:ho=\E[H:im=\E[4h:
616 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
617 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
619 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
620 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
621 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: