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;
216 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) {
219 $foo = `infocmp -C 2>/dev/null`;
220 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
228 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
230 $state = 1; # 0 == finished
234 $first = 0; # first entry (keeps term name)
236 $max = 32; # max :tc=...:'s
239 # ok, we're starting with $TERMCAP
240 $first++; # we're the first entry
241 # do we need to continue?
242 if ($entry =~ s/:tc=([^:]+):/:/) {
244 # protect any pattern metacharacters in $tmp_term
245 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
248 $state = 0; # we're already finished
252 # This is eval'ed inside the while loop for each file
255 next if /^\\t/ || /^#/;
256 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
258 s/^[^:]*:// if $first++;
260 while ($_ =~ s/\\\\$//) {
261 defined(my $x = <TERMCAP>) or last;
267 defined $entry or $entry = '';
271 while ($state != 0) {
273 # get the next TERMCAP
274 $TERMCAP = shift @termcap_path
275 || croak "failed termcap lookup on $tmp_term";
278 # do the same file again
279 # prevent endless recursion
280 $max-- || croak "failed termcap loop at $tmp_term";
281 $state = 1; # ok, maybe do a new file next time
284 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
289 # If :tc=...: found then search this file again
290 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
291 # protect any pattern metacharacters in $tmp_term
292 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
295 croak "Can't find $term" if $entry eq '';
296 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
297 $entry =~ s/:+/:/g; # cleanup $entry
298 $self->{TERMCAP} = $entry; # save it
299 # print STDERR "DEBUG: $entry = ", $entry, "\n";
301 # Precompile $entry into the object
302 $entry =~ s/^[^:]*://;
303 foreach $field (split(/:[\s:\\]*/,$entry)) {
304 if (defined $field && $field =~ /^(\w\w)$/) {
305 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
306 # print STDERR "DEBUG: flag $1\n";
308 elsif (defined $field && $field =~ /^(\w\w)\@/) {
309 $self->{'_' . $1} = "";
310 # print STDERR "DEBUG: unset $1\n";
312 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
313 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
314 # print STDERR "DEBUG: numeric $1 = $2\n";
316 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
317 # print STDERR "DEBUG: string $1 = $2\n";
318 next if defined $self->{'_' . ($cap = $1)};
321 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
329 s/\^(.)/pack('c',ord($1) & 31)/eg;
332 $self->{'_' . $cap} = $_;
334 # else { carp "junk in $term ignored: $field"; }
336 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
337 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
341 # $terminal->Tpad($string, $cnt, $FH);
345 Outputs a literal string with appropriate padding for the current terminal.
347 It takes three arguments:
353 The literal string to be output. If it starts with a number and an optional
354 '*' then the padding will be increased by an amount relative to this number,
355 if the '*' is present then this amount will me multiplied by $cnt. This part
356 of $string is removed before output/
360 Will be used to modify the padding applied to string as described above.
364 An optional filehandle (or IO::Handle ) that output will be printed to.
368 The padded $string is returned.
374 my($string, $cnt, $FH) = @_;
377 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
381 $decr = $self->{PADDING};
384 $string .= $self->{'_pc'} x ($ms / $decr);
387 print $FH $string if $FH;
391 # $terminal->Tputs($cap, $cnt, $FH);
395 Output the string for the given capability padded as appropriate without
396 any parameter substitution.
398 It takes three arguments:
404 The capability whose string is to be output.
408 A count passed to Tpad to modify the padding applied to the output string.
409 If $cnt is zero or one then the resulting string will be cached.
413 An optional filehandle (or IO::Handle ) that output will be printed to.
417 The appropriate string for the capability will be returned.
421 sub Tputs { ## public
423 my($cap, $cnt, $FH) = @_;
426 $cnt = 0 unless $cnt;
429 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
431 # cache result because Tpad can be slow
432 unless (exists $self->{$cap}) {
433 $self->{$cap} = exists $self->{"_$cap"} ?
434 Tpad($self, $self->{"_$cap"}, 1) : undef;
436 $string = $self->{$cap};
438 print $FH $string if $FH;
442 # $terminal->Tgoto($cap, $col, $row, $FH);
446 B<Tgoto> decodes a cursor addressing string with the given parameters.
448 There are four arguments:
454 The name of the capability to be output.
458 The first value to be substituted in the output string ( usually the column
459 in a cursor addressing capability )
463 The second value to be substituted in the output string (usually the row
464 in cursor addressing capabilities)
468 An optional filehandle (or IO::Handle ) to which the output string will be
473 Substitutions are made with $col and $row in the output string with the
474 following sprintf() line formats:
477 %d output value as in printf %d
478 %2 output value as in printf %2d
479 %3 output value as in printf %3d
480 %. output value as in printf %c
481 %+x add x to value, then do %.
483 %>xy if value > x then add y, no output
484 %r reverse order of two parameters, no output
485 %i increment by one, no output
486 %B BCD (16*(value/10)) + (value%10), no output
488 %n exclusive-or all parameters with 0140 (Datamedia 2500)
489 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
491 The output string will be returned.
495 sub Tgoto { ## public
497 my($cap, $code, $tmp, $FH) = @_;
498 my $string = $self->{'_' . $cap};
502 my @tmp = ($tmp,$code);
505 while ($string =~ /^([^%]*)%(.)(.*)/) {
510 $result .= sprintf("%d",shift(@tmp));
512 elsif ($code eq '.') {
514 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
516 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
519 ++$tmp, $after .= $self->{'_bc'};
522 $result .= sprintf("%c",$tmp);
525 elsif ($code eq '+') {
526 $result .= sprintf("%c",shift(@tmp)+ord($string));
527 $string = substr($string,1,99);
530 elsif ($code eq 'r') {
535 elsif ($code eq '>') {
536 ($code,$tmp,$string) = unpack("CCa99",$string);
537 if ($tmp[$[] > $code) {
541 elsif ($code eq '2') {
542 $result .= sprintf("%02d",shift(@tmp));
545 elsif ($code eq '3') {
546 $result .= sprintf("%03d",shift(@tmp));
549 elsif ($code eq 'i') {
551 @tmp = ($code+1,$tmp+1);
557 $string = Tpad($self, $result . $string . $after, $cnt);
558 print $FH $string if $FH;
562 # $terminal->Trequire(qw/ce ku kd/);
566 Takes a list of capabilities as an argument and will croak if one is not
571 sub Trequire { ## public
575 push(@undefined, $cap)
576 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
578 croak "Terminal does not support: (@undefined)" if @undefined;
587 # Get terminal output speed
589 my $termios = new POSIX::Termios;
591 my $ospeed = $termios->getospeed;
593 # Old-style ioctl code to get ospeed:
594 # require 'ioctl.pl';
595 # ioctl(TTY,$TIOCGETP,$sgtty);
596 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
598 # allocate and initialize a terminal structure
599 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
601 # require certain capabilities to be available
602 $terminal->Trequire(qw/ce ku kd/);
604 # Output Routines, if $FH is undefined these just return the string
606 # Tgoto does the % expansion stuff with the given args
607 $terminal->Tgoto('cm', $col, $row, $FH);
609 # Tputs doesn't do any % expansion.
610 $terminal->Tputs('dl', $count = 1, $FH);
612 =head1 COPYRIGHT AND LICENSE
614 Please see the README file in distribution.
618 This module is part of the core Perl distribution and is also maintained
619 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
627 # Below is a default entry for systems where there are terminals but no
631 vt220|vt200|DEC VT220 in vt100 emulation mode:
635 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
636 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
637 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
638 ei=\E[4l:ho=\E[H:im=\E[4h:
641 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
642 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
644 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
645 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
646 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: