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>
20 # Version 1.04: Thu Nov 29 16:22:03 GMT 2001
21 # Fixed warnings in test
24 # support Berkeley DB termcaps
25 # should probably be a .xs module
26 # force $FH into callers package?
27 # keep $FH in object at Tgetent time?
31 Term::Cap - Perl termcap interface
36 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
37 $terminal->Trequire(qw/ce ku kd/);
38 $terminal->Tgoto('cm', $col, $row, $FH);
39 $terminal->Tputs('dl', $count, $FH);
40 $terminal->Tpad($string, $count, $FH);
44 These are low-level functions to extract and use capabilities from
45 a terminal capability (termcap) database.
47 More information on the terminal capabilities will be found in the
48 termcap manpage on most Unix-like systems.
54 The output strings for B<Tputs> are cached for counts of 1 for performance.
55 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
56 data and C<$self-E<gt>{xx}> is the cached version.
58 print $terminal->Tpad($self->{_xx}, 1);
60 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
61 output the string to $FH if specified.
66 # Returns a list of termcap files to check.
67 sub termcap_path { ## private
69 # $TERMCAP, if it's a filespec
70 push(@termcap_path, $ENV{TERMCAP})
71 if ((exists $ENV{TERMCAP}) &&
72 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
73 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
74 : $ENV{TERMCAP} =~ /^\//s));
75 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
76 # Add the users $TERMPATH
77 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
82 $ENV{'HOME'} . '/.termcap',
84 '/usr/share/misc/termcap',
87 # return the list of those termcaps that exist
88 return grep(-f, @termcap_path);
93 Returns a blessed object reference which the user can
94 then use to send the control strings to the terminal using B<Tputs>
97 The function extracts the entry of the specified terminal
98 type I<TERM> (defaults to the environment variable I<TERM>) from the
101 It will look in the environment for a I<TERMCAP> variable. If
102 found, and the value does not begin with a slash, and the terminal
103 type name is the same as the environment string I<TERM>, the
104 I<TERMCAP> string is used instead of reading a termcap file. If
105 it does begin with a slash, the string is used as a path name of
106 the termcap file to search. If I<TERMCAP> does not begin with a
107 slash and name is different from I<TERM>, B<Tgetent> searches the
108 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
109 in that order, unless the environment variable I<TERMPATH> exists,
110 in which case it specifies a list of file pathnames (separated by
111 spaces or colons) to be searched B<instead>. Whenever multiple
112 files are searched and a tc field occurs in the requested entry,
113 the entry it names must be found in the same file or one of the
114 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
115 environment variable string it will continue the search in the
118 The extracted termcap entry is available in the object
119 as C<$self-E<gt>{TERMCAP}>.
121 It takes a hash reference as an argument with two optional keys:
127 The terminal output bit rate (often mistakenly called the baud rate)
128 for this terminal - if not set a warning will be generated
129 and it will be defaulted to 9600. I<OSPEED> can be be specified as
130 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
131 an old DSD-style speed ( where 13 equals 9600).
136 The terminal type whose termcap entry will be used - if not supplied it will
137 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
141 It calls C<croak> on failure.
145 sub Tgetent { ## public -- static method
149 $self = {} unless defined $self;
152 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
153 local($termpat,$state,$first,$entry); # used inside eval
156 # Compute PADDING factor from OSPEED (to be used by Tpad)
157 if (! $self->{OSPEED}) {
158 carp "OSPEED was not set, defaulting to 9600";
159 $self->{OSPEED} = 9600;
161 if ($self->{OSPEED} < 16) {
162 # delays for old style speeds
163 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);
164 $self->{PADDING} = $pad[$self->{OSPEED}];
167 $self->{PADDING} = 10000 / $self->{OSPEED};
170 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
171 $term = $self->{TERM}; # $term is the term type we are looking for
173 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
174 $tmp_term = $self->{TERM};
175 # protect any pattern metacharacters in $tmp_term
176 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
178 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
180 # $entry is the extracted termcap entry
181 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
185 my @termcap_path = termcap_path();
187 unless (@termcap_path || $entry)
189 # last resort--fake up a termcap from terminfo
190 local $ENV{TERM} = $term;
192 if ( $^O eq 'VMS' ) {
193 chomp(my @entry = <DATA>);
194 $entry = join '', @entry;
199 $entry = `infocmp -C 2>/dev/null`;
205 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
207 $state = 1; # 0 == finished
211 $first = 0; # first entry (keeps term name)
213 $max = 32; # max :tc=...:'s
216 # ok, we're starting with $TERMCAP
217 $first++; # we're the first entry
218 # do we need to continue?
219 if ($entry =~ s/:tc=([^:]+):/:/) {
221 # protect any pattern metacharacters in $tmp_term
222 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
225 $state = 0; # we're already finished
229 # This is eval'ed inside the while loop for each file
232 next if /^\\t/ || /^#/;
233 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
235 s/^[^:]*:// if $first++;
237 while ($_ =~ s/\\\\$//) {
238 defined(my $x = <TERMCAP>) or last;
244 defined $entry or $entry = '';
248 while ($state != 0) {
250 # get the next TERMCAP
251 $TERMCAP = shift @termcap_path
252 || croak "failed termcap lookup on $tmp_term";
255 # do the same file again
256 # prevent endless recursion
257 $max-- || croak "failed termcap loop at $tmp_term";
258 $state = 1; # ok, maybe do a new file next time
261 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
266 # If :tc=...: found then search this file again
267 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
268 # protect any pattern metacharacters in $tmp_term
269 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
272 croak "Can't find $term" if $entry eq '';
273 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
274 $entry =~ s/:+/:/g; # cleanup $entry
275 $self->{TERMCAP} = $entry; # save it
276 # print STDERR "DEBUG: $entry = ", $entry, "\n";
278 # Precompile $entry into the object
279 $entry =~ s/^[^:]*://;
280 foreach $field (split(/:[\s:\\]*/,$entry)) {
281 if (defined $field && $field =~ /^(\w\w)$/) {
282 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
283 # print STDERR "DEBUG: flag $1\n";
285 elsif (defined $field && $field =~ /^(\w\w)\@/) {
286 $self->{'_' . $1} = "";
287 # print STDERR "DEBUG: unset $1\n";
289 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
290 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
291 # print STDERR "DEBUG: numeric $1 = $2\n";
293 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
294 # print STDERR "DEBUG: string $1 = $2\n";
295 next if defined $self->{'_' . ($cap = $1)};
298 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
306 s/\^(.)/pack('c',ord($1) & 31)/eg;
309 $self->{'_' . $cap} = $_;
311 # else { carp "junk in $term ignored: $field"; }
313 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
314 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
318 # $terminal->Tpad($string, $cnt, $FH);
322 Outputs a literal string with appropriate padding for the current terminal.
324 It takes three arguments:
330 The literal string to be output. If it starts with a number and an optional
331 '*' then the padding will be increased by an amount relative to this number,
332 if the '*' is present then this amount will me multiplied by $cnt. This part
333 of $string is removed before output/
337 Will be used to modify the padding applied to string as described above.
341 An optional filehandle (or IO::Handle ) that output will be printed to.
345 The padded $string is returned.
351 my($string, $cnt, $FH) = @_;
354 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
358 $decr = $self->{PADDING};
361 $string .= $self->{'_pc'} x ($ms / $decr);
364 print $FH $string if $FH;
368 # $terminal->Tputs($cap, $cnt, $FH);
372 Output the string for the given capability padded as appropriate without
373 any parameter substitution.
375 It takes three arguments:
381 The capability whose string is to be output.
385 A count passed to Tpad to modify the padding applied to the output string.
386 If $cnt is zero or one then the resulting string will be cached.
390 An optional filehandle (or IO::Handle ) that output will be printed to.
394 The appropriate string for the capability will be returned.
398 sub Tputs { ## public
400 my($cap, $cnt, $FH) = @_;
403 $cnt = 0 unless $cnt;
406 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
408 # cache result because Tpad can be slow
409 unless (exists $self->{$cap}) {
410 $self->{$cap} = exists $self->{"_$cap"} ?
411 Tpad($self, $self->{"_$cap"}, 1) : undef;
413 $string = $self->{$cap};
415 print $FH $string if $FH;
419 # $terminal->Tgoto($cap, $col, $row, $FH);
423 B<Tgoto> decodes a cursor addressing string with the given parameters.
425 There are four arguments:
431 The name of the capability to be output.
435 The first value to be substituted in the output string ( usually the column
436 in a cursor addressing capability )
440 The second value to be substituted in the output string (usually the row
441 in cursor addressing capabilities)
445 An optional filehandle (or IO::Handle ) to which the output string will be
450 Substitutions are made with $col and $row in the output string with the
451 following sprintf() line formats:
454 %d output value as in printf %d
455 %2 output value as in printf %2d
456 %3 output value as in printf %3d
457 %. output value as in printf %c
458 %+x add x to value, then do %.
460 %>xy if value > x then add y, no output
461 %r reverse order of two parameters, no output
462 %i increment by one, no output
463 %B BCD (16*(value/10)) + (value%10), no output
465 %n exclusive-or all parameters with 0140 (Datamedia 2500)
466 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
468 The output string will be returned.
472 sub Tgoto { ## public
474 my($cap, $code, $tmp, $FH) = @_;
475 my $string = $self->{'_' . $cap};
479 my @tmp = ($tmp,$code);
482 while ($string =~ /^([^%]*)%(.)(.*)/) {
487 $result .= sprintf("%d",shift(@tmp));
489 elsif ($code eq '.') {
491 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
493 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
496 ++$tmp, $after .= $self->{'_bc'};
499 $result .= sprintf("%c",$tmp);
502 elsif ($code eq '+') {
503 $result .= sprintf("%c",shift(@tmp)+ord($string));
504 $string = substr($string,1,99);
507 elsif ($code eq 'r') {
512 elsif ($code eq '>') {
513 ($code,$tmp,$string) = unpack("CCa99",$string);
514 if ($tmp[$[] > $code) {
518 elsif ($code eq '2') {
519 $result .= sprintf("%02d",shift(@tmp));
522 elsif ($code eq '3') {
523 $result .= sprintf("%03d",shift(@tmp));
526 elsif ($code eq 'i') {
528 @tmp = ($code+1,$tmp+1);
534 $string = Tpad($self, $result . $string . $after, $cnt);
535 print $FH $string if $FH;
539 # $terminal->Trequire(qw/ce ku kd/);
543 Takes a list of capabilities as an argument and will croak if one is not
548 sub Trequire { ## public
552 push(@undefined, $cap)
553 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
555 croak "Terminal does not support: (@undefined)" if @undefined;
564 # Get terminal output speed
566 my $termios = new POSIX::Termios;
568 my $ospeed = $termios->getospeed;
570 # Old-style ioctl code to get ospeed:
571 # require 'ioctl.pl';
572 # ioctl(TTY,$TIOCGETP,$sgtty);
573 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
575 # allocate and initialize a terminal structure
576 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
578 # require certain capabilities to be available
579 $terminal->Trequire(qw/ce ku kd/);
581 # Output Routines, if $FH is undefined these just return the string
583 # Tgoto does the % expansion stuff with the given args
584 $terminal->Tgoto('cm', $col, $row, $FH);
586 # Tputs doesn't do any % expansion.
587 $terminal->Tputs('dl', $count = 1, $FH);
589 =head1 COPYRIGHT AND LICENSE
591 Please see the README file in distribution.
595 This module is part of the core Perl distribution and is also maintained
596 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
604 # Below is a default entry for systems where there are terminals but no
608 vt220|vt200|DEC VT220 in vt100 emulation mode:
612 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
613 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
614 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
615 ei=\E[4l:ho=\E[H:im=\E[4h:
618 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
619 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
621 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
622 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
623 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: