3 # Since the debugger uses Term::ReadLine which uses Term::Cap, we want
4 # to load as few modules as possible. This includes Carp.pm.
17 use vars qw($VERSION $VMS_TERMCAP);
18 use vars qw($termpat $state $first $entry);
22 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
23 # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
24 # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
25 # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
26 # Avoid warnings in Tgetent and Tputs
27 # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
28 # Altered layout of the POD
29 # Added Test::More to PREREQ_PM in Makefile.PL
30 # Fixed no argument Tgetent()
31 # Version 1.03: Wed Nov 28 10:09:38 GMT 2001
32 # VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
33 # Version 1.04: Thu Nov 29 16:22:03 GMT 2001
34 # Fixed warnings in test
35 # Version 1.05: Mon Dec 3 15:33:49 GMT 2001
36 # Don't try to fall back on infocmp if it's not there. From chromatic.
37 # Version 1.06: Thu Dec 6 18:43:22 GMT 2001
38 # Preload the default VMS termcap from Charles Lane
39 # Don't carp at setting OSPEED unless warnings are on.
40 # Version 1.07: Wed Jan 2 21:35:09 GMT 2002
41 # Sanity check on infocmp output from Norton Allen
42 # Repaired INSTALLDIRS thanks to Michael Schwern
43 # Version 1.08: Sat Sep 28 11:33:15 BST 2002
44 # Late loading of 'Carp' as per Michael Schwern
45 # Version 1.09: Tue Apr 20 12:06:51 BST 2004
46 # Merged in changes from and to Core
47 # Core (Fri Aug 30 14:15:55 CEST 2002):
48 # Cope with comments lines from 'infocmp' from Brendan O'Dea
49 # Allow for EBCDIC in Tgoto magic test.
52 # support Berkeley DB termcaps
53 # should probably be a .xs module
54 # force $FH into callers package?
55 # keep $FH in object at Tgetent time?
59 Term::Cap - Perl termcap interface
64 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
65 $terminal->Trequire(qw/ce ku kd/);
66 $terminal->Tgoto('cm', $col, $row, $FH);
67 $terminal->Tputs('dl', $count, $FH);
68 $terminal->Tpad($string, $count, $FH);
72 These are low-level functions to extract and use capabilities from
73 a terminal capability (termcap) database.
75 More information on the terminal capabilities will be found in the
76 termcap manpage on most Unix-like systems.
82 The output strings for B<Tputs> are cached for counts of 1 for performance.
83 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
84 data and C<$self-E<gt>{xx}> is the cached version.
86 print $terminal->Tpad($self->{_xx}, 1);
88 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
89 output the string to $FH if specified.
94 # Preload the default VMS termcap.
95 # If a different termcap is required then the text of one can be supplied
96 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
99 chomp (my @entry = <DATA>);
100 $VMS_TERMCAP = join '', @entry;
103 # Returns a list of termcap files to check.
105 sub termcap_path { ## private
107 # $TERMCAP, if it's a filespec
108 push(@termcap_path, $ENV{TERMCAP})
109 if ((exists $ENV{TERMCAP}) &&
110 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
111 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
112 : $ENV{TERMCAP} =~ /^\//s));
113 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
114 # Add the users $TERMPATH
115 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
120 $ENV{'HOME'} . '/.termcap',
122 '/usr/share/misc/termcap',
126 # return the list of those termcaps that exist
127 return grep(-f, @termcap_path);
132 Returns a blessed object reference which the user can
133 then use to send the control strings to the terminal using B<Tputs>
136 The function extracts the entry of the specified terminal
137 type I<TERM> (defaults to the environment variable I<TERM>) from the
140 It will look in the environment for a I<TERMCAP> variable. If
141 found, and the value does not begin with a slash, and the terminal
142 type name is the same as the environment string I<TERM>, the
143 I<TERMCAP> string is used instead of reading a termcap file. If
144 it does begin with a slash, the string is used as a path name of
145 the termcap file to search. If I<TERMCAP> does not begin with a
146 slash and name is different from I<TERM>, B<Tgetent> searches the
147 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
148 in that order, unless the environment variable I<TERMPATH> exists,
149 in which case it specifies a list of file pathnames (separated by
150 spaces or colons) to be searched B<instead>. Whenever multiple
151 files are searched and a tc field occurs in the requested entry,
152 the entry it names must be found in the same file or one of the
153 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
154 environment variable string it will continue the search in the
157 The extracted termcap entry is available in the object
158 as C<$self-E<gt>{TERMCAP}>.
160 It takes a hash reference as an argument with two optional keys:
166 The terminal output bit rate (often mistakenly called the baud rate)
167 for this terminal - if not set a warning will be generated
168 and it will be defaulted to 9600. I<OSPEED> can be be specified as
169 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
170 an old DSD-style speed ( where 13 equals 9600).
175 The terminal type whose termcap entry will be used - if not supplied it will
176 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
180 It calls C<croak> on failure.
184 sub Tgetent { ## public -- static method
188 $self = {} unless defined $self;
191 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
192 local($termpat,$state,$first,$entry); # used inside eval
195 # Compute PADDING factor from OSPEED (to be used by Tpad)
196 if (! $self->{OSPEED}) {
198 carp "OSPEED was not set, defaulting to 9600";
200 $self->{OSPEED} = 9600;
202 if ($self->{OSPEED} < 16) {
203 # delays for old style speeds
204 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);
205 $self->{PADDING} = $pad[$self->{OSPEED}];
208 $self->{PADDING} = 10000 / $self->{OSPEED};
211 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
212 $term = $self->{TERM}; # $term is the term type we are looking for
214 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
215 $tmp_term = $self->{TERM};
216 # protect any pattern metacharacters in $tmp_term
217 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
219 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
221 # $entry is the extracted termcap entry
222 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
226 my @termcap_path = termcap_path();
228 unless (@termcap_path || $entry)
230 # last resort--fake up a termcap from terminfo
231 local $ENV{TERM} = $term;
233 if ( $^O eq 'VMS' ) {
234 $entry = $VMS_TERMCAP;
237 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) {
240 my $tmp = `infocmp -C 2>/dev/null`;
241 $tmp =~ s/^#.*\n//gm; # remove comments
242 if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) {
250 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
252 $state = 1; # 0 == finished
256 $first = 0; # first entry (keeps term name)
258 $max = 32; # max :tc=...:'s
261 # ok, we're starting with $TERMCAP
262 $first++; # we're the first entry
263 # do we need to continue?
264 if ($entry =~ s/:tc=([^:]+):/:/) {
266 # protect any pattern metacharacters in $tmp_term
267 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
270 $state = 0; # we're already finished
274 # This is eval'ed inside the while loop for each file
277 next if /^\\t/ || /^#/;
278 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
280 s/^[^:]*:// if $first++;
282 while ($_ =~ s/\\\\$//) {
283 defined(my $x = <TERMCAP>) or last;
289 defined $entry or $entry = '';
293 while ($state != 0) {
295 # get the next TERMCAP
296 $TERMCAP = shift @termcap_path
297 || croak "failed termcap lookup on $tmp_term";
300 # do the same file again
301 # prevent endless recursion
302 $max-- || croak "failed termcap loop at $tmp_term";
303 $state = 1; # ok, maybe do a new file next time
306 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
311 # If :tc=...: found then search this file again
312 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
313 # protect any pattern metacharacters in $tmp_term
314 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
317 croak "Can't find $term" if $entry eq '';
318 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
319 $entry =~ s/:+/:/g; # cleanup $entry
320 $self->{TERMCAP} = $entry; # save it
321 # print STDERR "DEBUG: $entry = ", $entry, "\n";
323 # Precompile $entry into the object
324 $entry =~ s/^[^:]*://;
325 foreach $field (split(/:[\s:\\]*/,$entry)) {
326 if (defined $field && $field =~ /^(\w\w)$/) {
327 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
328 # print STDERR "DEBUG: flag $1\n";
330 elsif (defined $field && $field =~ /^(\w\w)\@/) {
331 $self->{'_' . $1} = "";
332 # print STDERR "DEBUG: unset $1\n";
334 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
335 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
336 # print STDERR "DEBUG: numeric $1 = $2\n";
338 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
339 # print STDERR "DEBUG: string $1 = $2\n";
340 next if defined $self->{'_' . ($cap = $1)};
343 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
351 s/\^(.)/pack('c',ord($1) & 31)/eg;
354 $self->{'_' . $cap} = $_;
356 # else { carp "junk in $term ignored: $field"; }
358 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
359 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
363 # $terminal->Tpad($string, $cnt, $FH);
367 Outputs a literal string with appropriate padding for the current terminal.
369 It takes three arguments:
375 The literal string to be output. If it starts with a number and an optional
376 '*' then the padding will be increased by an amount relative to this number,
377 if the '*' is present then this amount will me multiplied by $cnt. This part
378 of $string is removed before output/
382 Will be used to modify the padding applied to string as described above.
386 An optional filehandle (or IO::Handle ) that output will be printed to.
390 The padded $string is returned.
396 my($string, $cnt, $FH) = @_;
399 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
403 $decr = $self->{PADDING};
406 $string .= $self->{'_pc'} x ($ms / $decr);
409 print $FH $string if $FH;
413 # $terminal->Tputs($cap, $cnt, $FH);
417 Output the string for the given capability padded as appropriate without
418 any parameter substitution.
420 It takes three arguments:
426 The capability whose string is to be output.
430 A count passed to Tpad to modify the padding applied to the output string.
431 If $cnt is zero or one then the resulting string will be cached.
435 An optional filehandle (or IO::Handle ) that output will be printed to.
439 The appropriate string for the capability will be returned.
443 sub Tputs { ## public
445 my($cap, $cnt, $FH) = @_;
448 $cnt = 0 unless $cnt;
451 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
453 # cache result because Tpad can be slow
454 unless (exists $self->{$cap}) {
455 $self->{$cap} = exists $self->{"_$cap"} ?
456 Tpad($self, $self->{"_$cap"}, 1) : undef;
458 $string = $self->{$cap};
460 print $FH $string if $FH;
464 # $terminal->Tgoto($cap, $col, $row, $FH);
468 B<Tgoto> decodes a cursor addressing string with the given parameters.
470 There are four arguments:
476 The name of the capability to be output.
480 The first value to be substituted in the output string ( usually the column
481 in a cursor addressing capability )
485 The second value to be substituted in the output string (usually the row
486 in cursor addressing capabilities)
490 An optional filehandle (or IO::Handle ) to which the output string will be
495 Substitutions are made with $col and $row in the output string with the
496 following sprintf() line formats:
499 %d output value as in printf %d
500 %2 output value as in printf %2d
501 %3 output value as in printf %3d
502 %. output value as in printf %c
503 %+x add x to value, then do %.
505 %>xy if value > x then add y, no output
506 %r reverse order of two parameters, no output
507 %i increment by one, no output
508 %B BCD (16*(value/10)) + (value%10), no output
510 %n exclusive-or all parameters with 0140 (Datamedia 2500)
511 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
513 The output string will be returned.
517 sub Tgoto { ## public
519 my($cap, $code, $tmp, $FH) = @_;
520 my $string = $self->{'_' . $cap};
524 my @tmp = ($tmp,$code);
527 while ($string =~ /^([^%]*)%(.)(.*)/) {
532 $result .= sprintf("%d",shift(@tmp));
534 elsif ($code eq '.') {
536 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
538 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
541 ++$tmp, $after .= $self->{'_bc'};
544 $result .= sprintf("%c",$tmp);
547 elsif ($code eq '+') {
548 $result .= sprintf("%c",shift(@tmp)+ord($string));
549 $string = substr($string,1,99);
552 elsif ($code eq 'r') {
557 elsif ($code eq '>') {
558 ($code,$tmp,$string) = unpack("CCa99",$string);
559 if ($tmp[$[] > $code) {
563 elsif ($code eq '2') {
564 $result .= sprintf("%02d",shift(@tmp));
567 elsif ($code eq '3') {
568 $result .= sprintf("%03d",shift(@tmp));
571 elsif ($code eq 'i') {
573 @tmp = ($code+1,$tmp+1);
579 $string = Tpad($self, $result . $string . $after, $cnt);
580 print $FH $string if $FH;
584 # $terminal->Trequire(qw/ce ku kd/);
588 Takes a list of capabilities as an argument and will croak if one is not
593 sub Trequire { ## public
597 push(@undefined, $cap)
598 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
600 croak "Terminal does not support: (@undefined)" if @undefined;
609 # Get terminal output speed
611 my $termios = new POSIX::Termios;
613 my $ospeed = $termios->getospeed;
615 # Old-style ioctl code to get ospeed:
616 # require 'ioctl.pl';
617 # ioctl(TTY,$TIOCGETP,$sgtty);
618 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
620 # allocate and initialize a terminal structure
621 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
623 # require certain capabilities to be available
624 $terminal->Trequire(qw/ce ku kd/);
626 # Output Routines, if $FH is undefined these just return the string
628 # Tgoto does the % expansion stuff with the given args
629 $terminal->Tgoto('cm', $col, $row, $FH);
631 # Tputs doesn't do any % expansion.
632 $terminal->Tputs('dl', $count = 1, $FH);
634 =head1 COPYRIGHT AND LICENSE
636 Please see the README file in distribution.
640 This module is part of the core Perl distribution and is also maintained
641 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
649 # Below is a default entry for systems where there are terminals but no
653 vt220|vt200|DEC VT220 in vt100 emulation mode:
657 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
658 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
659 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
660 ei=\E[4l:ho=\E[H:im=\E[4h:
663 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
664 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
666 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
667 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
668 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: