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.
19 use vars qw($VERSION $VMS_TERMCAP);
20 use vars qw($termpat $state $first $entry);
24 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
25 # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
26 # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
27 # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
28 # Avoid warnings in Tgetent and Tputs
29 # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
30 # Altered layout of the POD
31 # Added Test::More to PREREQ_PM in Makefile.PL
32 # Fixed no argument Tgetent()
33 # Version 1.03: Wed Nov 28 10:09:38 GMT 2001
34 # VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
35 # Version 1.04: Thu Nov 29 16:22:03 GMT 2001
36 # Fixed warnings in test
37 # Version 1.05: Mon Dec 3 15:33:49 GMT 2001
38 # Don't try to fall back on infocmp if it's not there. From chromatic.
39 # Version 1.06: Thu Dec 6 18:43:22 GMT 2001
40 # Preload the default VMS termcap from Charles Lane
41 # Don't carp at setting OSPEED unless warnings are on.
42 # Version 1.07: Wed Jan 2 21:35:09 GMT 2002
43 # Sanity check on infocmp output from Norton Allen
44 # Repaired INSTALLDIRS thanks to Michael Schwern
45 # Version 1.08: Sat Sep 28 11:33:15 BST 2002
46 # Late loading of 'Carp' as per Michael Schwern
47 # Version 1.09: Tue Apr 20 12:06:51 BST 2004
48 # Merged in changes from and to Core
49 # Core (Fri Aug 30 14:15:55 CEST 2002):
50 # Cope with comments lines from 'infocmp' from Brendan O'Dea
51 # Allow for EBCDIC in Tgoto magic test.
52 # Version 1.10: Thu Oct 18 16:52:20 BST 2007
53 # Don't use try to use $ENV{HOME} if it doesn't exist
54 # Give Win32 'dumb' if TERM isn't set
55 # Provide fallback 'dumb' termcap entry as last resort
56 # Version 1.11: Thu Oct 25 09:33:07 BST 2007
57 # EBDIC fixes from Chun Bing Ge <gecb@cn.ibm.com>
58 # Version 1.12: Sat Dec 8 00:10:21 GMT 2007
59 # QNX test fix from Matt Kraai <kraai@ftbfs.org>
62 # support Berkeley DB termcaps
63 # force $FH into callers package?
64 # keep $FH in object at Tgetent time?
68 Term::Cap - Perl termcap interface
73 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
74 $terminal->Trequire(qw/ce ku kd/);
75 $terminal->Tgoto('cm', $col, $row, $FH);
76 $terminal->Tputs('dl', $count, $FH);
77 $terminal->Tpad($string, $count, $FH);
81 These are low-level functions to extract and use capabilities from
82 a terminal capability (termcap) database.
84 More information on the terminal capabilities will be found in the
85 termcap manpage on most Unix-like systems.
91 The output strings for B<Tputs> are cached for counts of 1 for performance.
92 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
93 data and C<$self-E<gt>{xx}> is the cached version.
95 print $terminal->Tpad($self->{_xx}, 1);
97 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
98 output the string to $FH if specified.
103 # Preload the default VMS termcap.
104 # If a different termcap is required then the text of one can be supplied
105 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
109 chomp( my @entry = <DATA> );
110 $VMS_TERMCAP = join '', @entry;
113 # Returns a list of termcap files to check.
119 # $TERMCAP, if it's a filespec
120 push( @termcap_path, $ENV{TERMCAP} )
122 ( exists $ENV{TERMCAP} )
124 ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
125 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
126 : $ENV{TERMCAP} =~ /^\//s
129 if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
132 # Add the users $TERMPATH
133 push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
140 exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
141 '/etc/termcap', '/usr/share/misc/termcap', );
144 # return the list of those termcaps that exist
145 return grep { defined $_ && -f $_ } @termcap_path;
150 Returns a blessed object reference which the user can
151 then use to send the control strings to the terminal using B<Tputs>
154 The function extracts the entry of the specified terminal
155 type I<TERM> (defaults to the environment variable I<TERM>) from the
158 It will look in the environment for a I<TERMCAP> variable. If
159 found, and the value does not begin with a slash, and the terminal
160 type name is the same as the environment string I<TERM>, the
161 I<TERMCAP> string is used instead of reading a termcap file. If
162 it does begin with a slash, the string is used as a path name of
163 the termcap file to search. If I<TERMCAP> does not begin with a
164 slash and name is different from I<TERM>, B<Tgetent> searches the
165 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
166 in that order, unless the environment variable I<TERMPATH> exists,
167 in which case it specifies a list of file pathnames (separated by
168 spaces or colons) to be searched B<instead>. Whenever multiple
169 files are searched and a tc field occurs in the requested entry,
170 the entry it names must be found in the same file or one of the
171 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
172 environment variable string it will continue the search in the
175 The extracted termcap entry is available in the object
176 as C<$self-E<gt>{TERMCAP}>.
178 It takes a hash reference as an argument with two optional keys:
184 The terminal output bit rate (often mistakenly called the baud rate)
185 for this terminal - if not set a warning will be generated
186 and it will be defaulted to 9600. I<OSPEED> can be be specified as
187 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
188 an old DSD-style speed ( where 13 equals 9600).
193 The terminal type whose termcap entry will be used - if not supplied it will
194 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
198 It calls C<croak> on failure.
203 { ## public -- static method
207 $self = {} unless defined $self;
210 my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
211 local ( $termpat, $state, $first, $entry ); # used inside eval
214 # Compute PADDING factor from OSPEED (to be used by Tpad)
215 if ( !$self->{OSPEED} )
219 carp "OSPEED was not set, defaulting to 9600";
221 $self->{OSPEED} = 9600;
223 if ( $self->{OSPEED} < 16 )
226 # delays for old style speeds
228 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
229 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
231 $self->{PADDING} = $pad[ $self->{OSPEED} ];
235 $self->{PADDING} = 10000 / $self->{OSPEED};
238 unless ( $self->{TERM} )
242 $self->{TERM} = $ENV{TERM} ;
246 if ( $^O eq 'Win32' )
248 $self->{TERM} = 'dumb';
252 croak "TERM not set";
257 $term = $self->{TERM}; # $term is the term type we are looking for
259 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
260 $tmp_term = $self->{TERM};
262 # protect any pattern metacharacters in $tmp_term
263 $termpat = $tmp_term;
264 $termpat =~ s/(\W)/\\$1/g;
266 my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
268 # $entry is the extracted termcap entry
269 if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
274 my @termcap_path = termcap_path();
276 unless ( @termcap_path || $entry )
279 # last resort--fake up a termcap from terminfo
280 local $ENV{TERM} = $term;
284 $entry = $VMS_TERMCAP;
288 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
291 my $tmp = `infocmp -C 2>/dev/null`;
292 $tmp =~ s/^#.*\n//gm; # remove comments
293 if ( ( $tmp !~ m%^/%s )
294 && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
302 # this is getting desperate now
303 if ( $self->{TERM} eq 'dumb' )
305 $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
311 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
313 $state = 1; # 0 == finished
317 $first = 0; # first entry (keeps term name)
319 $max = 32; # max :tc=...:'s
324 # ok, we're starting with $TERMCAP
325 $first++; # we're the first entry
326 # do we need to continue?
327 if ( $entry =~ s/:tc=([^:]+):/:/ )
331 # protect any pattern metacharacters in $tmp_term
332 $termpat = $tmp_term;
333 $termpat =~ s/(\W)/\\$1/g;
337 $state = 0; # we're already finished
341 # This is eval'ed inside the while loop for each file
344 next if /^\\t/ || /^#/;
345 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
347 s/^[^:]*:// if $first++;
349 while ($_ =~ s/\\\\$//) {
350 defined(my $x = <TERMCAP>) or last;
356 defined $entry or $entry = '';
360 while ( $state != 0 )
365 # get the next TERMCAP
366 $TERMCAP = shift @termcap_path
367 || croak "failed termcap lookup on $tmp_term";
372 # do the same file again
373 # prevent endless recursion
374 $max-- || croak "failed termcap loop at $tmp_term";
375 $state = 1; # ok, maybe do a new file next time
378 open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
383 # If :tc=...: found then search this file again
384 $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
386 # protect any pattern metacharacters in $tmp_term
387 $termpat = $tmp_term;
388 $termpat =~ s/(\W)/\\$1/g;
391 croak "Can't find $term" if $entry eq '';
392 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
393 $entry =~ s/:+/:/g; # cleanup $entry
394 $self->{TERMCAP} = $entry; # save it
395 # print STDERR "DEBUG: $entry = ", $entry, "\n";
397 # Precompile $entry into the object
398 $entry =~ s/^[^:]*://;
399 foreach $field ( split( /:[\s:\\]*/, $entry ) )
401 if ( defined $field && $field =~ /^(\w\w)$/ )
403 $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
405 # print STDERR "DEBUG: flag $1\n";
407 elsif ( defined $field && $field =~ /^(\w\w)\@/ )
409 $self->{ '_' . $1 } = "";
411 # print STDERR "DEBUG: unset $1\n";
413 elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
415 $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
417 # print STDERR "DEBUG: numeric $1 = $2\n";
419 elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
422 # print STDERR "DEBUG: string $1 = $2\n";
423 next if defined $self->{ '_' . ( $cap = $1 ) };
425 if ( ord('A') == 193 )
428 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
436 s/\^(.)/pack('c',ord($1) & 31)/eg;
443 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
451 s/\^(.)/pack('c',ord($1) & 31)/eg;
455 $self->{ '_' . $cap } = $_;
458 # else { carp "junk in $term ignored: $field"; }
460 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
461 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
465 # $terminal->Tpad($string, $cnt, $FH);
469 Outputs a literal string with appropriate padding for the current terminal.
471 It takes three arguments:
477 The literal string to be output. If it starts with a number and an optional
478 '*' then the padding will be increased by an amount relative to this number,
479 if the '*' is present then this amount will me multiplied by $cnt. This part
480 of $string is removed before output/
484 Will be used to modify the padding applied to string as described above.
488 An optional filehandle (or IO::Handle ) that output will be printed to.
492 The padded $string is returned.
499 my ( $string, $cnt, $FH ) = @_;
502 if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
507 $decr = $self->{PADDING};
511 $string .= $self->{'_pc'} x ( $ms / $decr );
514 print $FH $string if $FH;
518 # $terminal->Tputs($cap, $cnt, $FH);
522 Output the string for the given capability padded as appropriate without
523 any parameter substitution.
525 It takes three arguments:
531 The capability whose string is to be output.
535 A count passed to Tpad to modify the padding applied to the output string.
536 If $cnt is zero or one then the resulting string will be cached.
540 An optional filehandle (or IO::Handle ) that output will be printed to.
544 The appropriate string for the capability will be returned.
551 my ( $cap, $cnt, $FH ) = @_;
554 $cnt = 0 unless $cnt;
558 $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
563 # cache result because Tpad can be slow
564 unless ( exists $self->{$cap} )
567 exists $self->{"_$cap"}
568 ? Tpad( $self, $self->{"_$cap"}, 1 )
571 $string = $self->{$cap};
573 print $FH $string if $FH;
577 # $terminal->Tgoto($cap, $col, $row, $FH);
581 B<Tgoto> decodes a cursor addressing string with the given parameters.
583 There are four arguments:
589 The name of the capability to be output.
593 The first value to be substituted in the output string ( usually the column
594 in a cursor addressing capability )
598 The second value to be substituted in the output string (usually the row
599 in cursor addressing capabilities)
603 An optional filehandle (or IO::Handle ) to which the output string will be
608 Substitutions are made with $col and $row in the output string with the
609 following sprintf() line formats:
612 %d output value as in printf %d
613 %2 output value as in printf %2d
614 %3 output value as in printf %3d
615 %. output value as in printf %c
616 %+x add x to value, then do %.
618 %>xy if value > x then add y, no output
619 %r reverse order of two parameters, no output
620 %i increment by one, no output
621 %B BCD (16*(value/10)) + (value%10), no output
623 %n exclusive-or all parameters with 0140 (Datamedia 2500)
624 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
626 The output string will be returned.
633 my ( $cap, $code, $tmp, $FH ) = @_;
634 my $string = $self->{ '_' . $cap };
638 my @tmp = ( $tmp, $code );
641 while ( $string =~ /^([^%]*)%(.)(.*)/ )
648 $result .= sprintf( "%d", shift(@tmp) );
650 elsif ( $code eq '.' )
653 if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
657 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
661 ++$tmp, $after .= $self->{'_bc'};
664 $result .= sprintf( "%c", $tmp );
667 elsif ( $code eq '+' )
669 $result .= sprintf( "%c", shift(@tmp) + ord($string) );
670 $string = substr( $string, 1, 99 );
673 elsif ( $code eq 'r' )
675 ( $code, $tmp ) = @tmp;
676 @tmp = ( $tmp, $code );
679 elsif ( $code eq '>' )
681 ( $code, $tmp, $string ) = unpack( "CCa99", $string );
682 if ( $tmp[$[] > $code )
687 elsif ( $code eq '2' )
689 $result .= sprintf( "%02d", shift(@tmp) );
692 elsif ( $code eq '3' )
694 $result .= sprintf( "%03d", shift(@tmp) );
697 elsif ( $code eq 'i' )
699 ( $code, $tmp ) = @tmp;
700 @tmp = ( $code + 1, $tmp + 1 );
707 $string = Tpad( $self, $result . $string . $after, $cnt );
708 print $FH $string if $FH;
712 # $terminal->Trequire(qw/ce ku kd/);
716 Takes a list of capabilities as an argument and will croak if one is not
724 my ( $cap, @undefined );
727 push( @undefined, $cap )
728 unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
730 croak "Terminal does not support: (@undefined)" if @undefined;
739 # Get terminal output speed
741 my $termios = new POSIX::Termios;
743 my $ospeed = $termios->getospeed;
745 # Old-style ioctl code to get ospeed:
746 # require 'ioctl.pl';
747 # ioctl(TTY,$TIOCGETP,$sgtty);
748 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
750 # allocate and initialize a terminal structure
751 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
753 # require certain capabilities to be available
754 $terminal->Trequire(qw/ce ku kd/);
756 # Output Routines, if $FH is undefined these just return the string
758 # Tgoto does the % expansion stuff with the given args
759 $terminal->Tgoto('cm', $col, $row, $FH);
761 # Tputs doesn't do any % expansion.
762 $terminal->Tputs('dl', $count = 1, $FH);
764 =head1 COPYRIGHT AND LICENSE
766 Please see the README file in distribution.
770 This module is part of the core Perl distribution and is also maintained
771 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
779 # Below is a default entry for systems where there are terminals but no
783 vt220|vt200|DEC VT220 in vt100 emulation mode:
787 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
788 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
789 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
790 ei=\E[4l:ho=\E[H:im=\E[4h:
793 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
794 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
796 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
797 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
798 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: