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>
60 # Version 1.13: Thu Dec 22 22:21:09 GMT 2011
61 # POD error fix from Domin Hargreaves <dom@earth.li>
64 # support Berkeley DB termcaps
65 # force $FH into callers package?
66 # keep $FH in object at Tgetent time?
70 Term::Cap - Perl termcap interface
75 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
76 $terminal->Trequire(qw/ce ku kd/);
77 $terminal->Tgoto('cm', $col, $row, $FH);
78 $terminal->Tputs('dl', $count, $FH);
79 $terminal->Tpad($string, $count, $FH);
83 These are low-level functions to extract and use capabilities from
84 a terminal capability (termcap) database.
86 More information on the terminal capabilities will be found in the
87 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;
152 Returns a blessed object reference which the user can
153 then use to send the control strings to the terminal using B<Tputs>
156 The function extracts the entry of the specified terminal
157 type I<TERM> (defaults to the environment variable I<TERM>) from the
160 It will look in the environment for a I<TERMCAP> variable. If
161 found, and the value does not begin with a slash, and the terminal
162 type name is the same as the environment string I<TERM>, the
163 I<TERMCAP> string is used instead of reading a termcap file. If
164 it does begin with a slash, the string is used as a path name of
165 the termcap file to search. If I<TERMCAP> does not begin with a
166 slash and name is different from I<TERM>, B<Tgetent> searches the
167 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
168 in that order, unless the environment variable I<TERMPATH> exists,
169 in which case it specifies a list of file pathnames (separated by
170 spaces or colons) to be searched B<instead>. Whenever multiple
171 files are searched and a tc field occurs in the requested entry,
172 the entry it names must be found in the same file or one of the
173 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
174 environment variable string it will continue the search in the
177 The extracted termcap entry is available in the object
178 as C<$self-E<gt>{TERMCAP}>.
180 It takes a hash reference as an argument with two optional keys:
186 The terminal output bit rate (often mistakenly called the baud rate)
187 for this terminal - if not set a warning will be generated
188 and it will be defaulted to 9600. I<OSPEED> can be be specified as
189 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
190 an old DSD-style speed ( where 13 equals 9600).
195 The terminal type whose termcap entry will be used - if not supplied it will
196 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
200 It calls C<croak> on failure.
205 { ## public -- static method
209 $self = {} unless defined $self;
212 my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
213 local ( $termpat, $state, $first, $entry ); # used inside eval
216 # Compute PADDING factor from OSPEED (to be used by Tpad)
217 if ( !$self->{OSPEED} )
221 carp "OSPEED was not set, defaulting to 9600";
223 $self->{OSPEED} = 9600;
225 if ( $self->{OSPEED} < 16 )
228 # delays for old style speeds
230 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
231 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
233 $self->{PADDING} = $pad[ $self->{OSPEED} ];
237 $self->{PADDING} = 10000 / $self->{OSPEED};
240 unless ( $self->{TERM} )
244 $self->{TERM} = $ENV{TERM} ;
248 if ( $^O eq 'Win32' )
250 $self->{TERM} = 'dumb';
254 croak "TERM not set";
259 $term = $self->{TERM}; # $term is the term type we are looking for
261 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
262 $tmp_term = $self->{TERM};
264 # protect any pattern metacharacters in $tmp_term
265 $termpat = $tmp_term;
266 $termpat =~ s/(\W)/\\$1/g;
268 my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
270 # $entry is the extracted termcap entry
271 if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
276 my @termcap_path = termcap_path();
278 unless ( @termcap_path || $entry )
281 # last resort--fake up a termcap from terminfo
282 local $ENV{TERM} = $term;
286 $entry = $VMS_TERMCAP;
290 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
293 my $tmp = `infocmp -C 2>/dev/null`;
294 $tmp =~ s/^#.*\n//gm; # remove comments
295 if ( ( $tmp !~ m%^/%s )
296 && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
304 # this is getting desperate now
305 if ( $self->{TERM} eq 'dumb' )
307 $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
313 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
315 $state = 1; # 0 == finished
319 $first = 0; # first entry (keeps term name)
321 $max = 32; # max :tc=...:'s
326 # ok, we're starting with $TERMCAP
327 $first++; # we're the first entry
328 # do we need to continue?
329 if ( $entry =~ s/:tc=([^:]+):/:/ )
333 # protect any pattern metacharacters in $tmp_term
334 $termpat = $tmp_term;
335 $termpat =~ s/(\W)/\\$1/g;
339 $state = 0; # we're already finished
343 # This is eval'ed inside the while loop for each file
346 next if /^\\t/ || /^#/;
347 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
349 s/^[^:]*:// if $first++;
351 while ($_ =~ s/\\\\$//) {
352 defined(my $x = <TERMCAP>) or last;
358 defined $entry or $entry = '';
362 while ( $state != 0 )
367 # get the next TERMCAP
368 $TERMCAP = shift @termcap_path
369 || croak "failed termcap lookup on $tmp_term";
374 # do the same file again
375 # prevent endless recursion
376 $max-- || croak "failed termcap loop at $tmp_term";
377 $state = 1; # ok, maybe do a new file next time
380 open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
385 # If :tc=...: found then search this file again
386 $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
388 # protect any pattern metacharacters in $tmp_term
389 $termpat = $tmp_term;
390 $termpat =~ s/(\W)/\\$1/g;
393 croak "Can't find $term" if $entry eq '';
394 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
395 $entry =~ s/:+/:/g; # cleanup $entry
396 $self->{TERMCAP} = $entry; # save it
397 # print STDERR "DEBUG: $entry = ", $entry, "\n";
399 # Precompile $entry into the object
400 $entry =~ s/^[^:]*://;
401 foreach $field ( split( /:[\s:\\]*/, $entry ) )
403 if ( defined $field && $field =~ /^(\w\w)$/ )
405 $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
407 # print STDERR "DEBUG: flag $1\n";
409 elsif ( defined $field && $field =~ /^(\w\w)\@/ )
411 $self->{ '_' . $1 } = "";
413 # print STDERR "DEBUG: unset $1\n";
415 elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
417 $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
419 # print STDERR "DEBUG: numeric $1 = $2\n";
421 elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
424 # print STDERR "DEBUG: string $1 = $2\n";
425 next if defined $self->{ '_' . ( $cap = $1 ) };
427 if ( ord('A') == 193 )
430 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
438 s/\^(.)/pack('c',ord($1) & 31)/eg;
445 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
453 s/\^(.)/pack('c',ord($1) & 31)/eg;
457 $self->{ '_' . $cap } = $_;
460 # else { carp "junk in $term ignored: $field"; }
462 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
463 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
467 # $terminal->Tpad($string, $cnt, $FH);
471 Outputs a literal string with appropriate padding for the current terminal.
473 It takes three arguments:
479 The literal string to be output. If it starts with a number and an optional
480 '*' then the padding will be increased by an amount relative to this number,
481 if the '*' is present then this amount will me multiplied by $cnt. This part
482 of $string is removed before output/
486 Will be used to modify the padding applied to string as described above.
490 An optional filehandle (or IO::Handle ) that output will be printed to.
494 The padded $string is returned.
501 my ( $string, $cnt, $FH ) = @_;
504 if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
509 $decr = $self->{PADDING};
513 $string .= $self->{'_pc'} x ( $ms / $decr );
516 print $FH $string if $FH;
520 # $terminal->Tputs($cap, $cnt, $FH);
524 Output the string for the given capability padded as appropriate without
525 any parameter substitution.
527 It takes three arguments:
533 The capability whose string is to be output.
537 A count passed to Tpad to modify the padding applied to the output string.
538 If $cnt is zero or one then the resulting string will be cached.
542 An optional filehandle (or IO::Handle ) that output will be printed to.
546 The appropriate string for the capability will be returned.
553 my ( $cap, $cnt, $FH ) = @_;
556 $cnt = 0 unless $cnt;
560 $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
565 # cache result because Tpad can be slow
566 unless ( exists $self->{$cap} )
569 exists $self->{"_$cap"}
570 ? Tpad( $self, $self->{"_$cap"}, 1 )
573 $string = $self->{$cap};
575 print $FH $string if $FH;
579 # $terminal->Tgoto($cap, $col, $row, $FH);
583 B<Tgoto> decodes a cursor addressing string with the given parameters.
585 There are four arguments:
591 The name of the capability to be output.
595 The first value to be substituted in the output string ( usually the column
596 in a cursor addressing capability )
600 The second value to be substituted in the output string (usually the row
601 in cursor addressing capabilities)
605 An optional filehandle (or IO::Handle ) to which the output string will be
610 Substitutions are made with $col and $row in the output string with the
611 following sprintf() line formats:
614 %d output value as in printf %d
615 %2 output value as in printf %2d
616 %3 output value as in printf %3d
617 %. output value as in printf %c
618 %+x add x to value, then do %.
620 %>xy if value > x then add y, no output
621 %r reverse order of two parameters, no output
622 %i increment by one, no output
623 %B BCD (16*(value/10)) + (value%10), no output
625 %n exclusive-or all parameters with 0140 (Datamedia 2500)
626 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
628 The output string will be returned.
635 my ( $cap, $code, $tmp, $FH ) = @_;
636 my $string = $self->{ '_' . $cap };
640 my @tmp = ( $tmp, $code );
643 while ( $string =~ /^([^%]*)%(.)(.*)/ )
650 $result .= sprintf( "%d", shift(@tmp) );
652 elsif ( $code eq '.' )
655 if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
659 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
663 ++$tmp, $after .= $self->{'_bc'};
666 $result .= sprintf( "%c", $tmp );
669 elsif ( $code eq '+' )
671 $result .= sprintf( "%c", shift(@tmp) + ord($string) );
672 $string = substr( $string, 1, 99 );
675 elsif ( $code eq 'r' )
677 ( $code, $tmp ) = @tmp;
678 @tmp = ( $tmp, $code );
681 elsif ( $code eq '>' )
683 ( $code, $tmp, $string ) = unpack( "CCa99", $string );
684 if ( $tmp[$[] > $code )
689 elsif ( $code eq '2' )
691 $result .= sprintf( "%02d", shift(@tmp) );
694 elsif ( $code eq '3' )
696 $result .= sprintf( "%03d", shift(@tmp) );
699 elsif ( $code eq 'i' )
701 ( $code, $tmp ) = @tmp;
702 @tmp = ( $code + 1, $tmp + 1 );
709 $string = Tpad( $self, $result . $string . $after, $cnt );
710 print $FH $string if $FH;
714 # $terminal->Trequire(qw/ce ku kd/);
718 Takes a list of capabilities as an argument and will croak if one is not
726 my ( $cap, @undefined );
729 push( @undefined, $cap )
730 unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
732 croak "Terminal does not support: (@undefined)" if @undefined;
741 # Get terminal output speed
743 my $termios = new POSIX::Termios;
745 my $ospeed = $termios->getospeed;
747 # Old-style ioctl code to get ospeed:
748 # require 'ioctl.pl';
749 # ioctl(TTY,$TIOCGETP,$sgtty);
750 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
752 # allocate and initialize a terminal structure
753 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
755 # require certain capabilities to be available
756 $terminal->Trequire(qw/ce ku kd/);
758 # Output Routines, if $FH is undefined these just return the string
760 # Tgoto does the % expansion stuff with the given args
761 $terminal->Tgoto('cm', $col, $row, $FH);
763 # Tputs doesn't do any % expansion.
764 $terminal->Tputs('dl', $count = 1, $FH);
766 =head1 COPYRIGHT AND LICENSE
768 Please see the README file in distribution.
772 This module is part of the core Perl distribution and is also maintained
773 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
781 # Below is a default entry for systems where there are terminals but no
785 vt220|vt200|DEC VT220 in vt100 emulation mode:
789 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
790 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
791 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
792 ei=\E[4l:ho=\E[H:im=\E[4h:
795 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
796 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
798 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
799 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
800 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: