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
58 # support Berkeley DB termcaps
59 # force $FH into callers package?
60 # keep $FH in object at Tgetent time?
64 Term::Cap - Perl termcap interface
69 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
70 $terminal->Trequire(qw/ce ku kd/);
71 $terminal->Tgoto('cm', $col, $row, $FH);
72 $terminal->Tputs('dl', $count, $FH);
73 $terminal->Tpad($string, $count, $FH);
77 These are low-level functions to extract and use capabilities from
78 a terminal capability (termcap) database.
80 More information on the terminal capabilities will be found in the
81 termcap manpage on most Unix-like systems.
87 The output strings for B<Tputs> are cached for counts of 1 for performance.
88 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
89 data and C<$self-E<gt>{xx}> is the cached version.
91 print $terminal->Tpad($self->{_xx}, 1);
93 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
94 output the string to $FH if specified.
99 # Preload the default VMS termcap.
100 # If a different termcap is required then the text of one can be supplied
101 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
105 chomp( my @entry = <DATA> );
106 $VMS_TERMCAP = join '', @entry;
109 # Returns a list of termcap files to check.
115 # $TERMCAP, if it's a filespec
116 push( @termcap_path, $ENV{TERMCAP} )
118 ( exists $ENV{TERMCAP} )
120 ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
121 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
122 : $ENV{TERMCAP} =~ /^\//s
125 if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
128 # Add the users $TERMPATH
129 push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
136 exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
137 '/etc/termcap', '/usr/share/misc/termcap', );
140 # return the list of those termcaps that exist
141 return grep { defined $_ && -f $_ } @termcap_path;
146 Returns a blessed object reference which the user can
147 then use to send the control strings to the terminal using B<Tputs>
150 The function extracts the entry of the specified terminal
151 type I<TERM> (defaults to the environment variable I<TERM>) from the
154 It will look in the environment for a I<TERMCAP> variable. If
155 found, and the value does not begin with a slash, and the terminal
156 type name is the same as the environment string I<TERM>, the
157 I<TERMCAP> string is used instead of reading a termcap file. If
158 it does begin with a slash, the string is used as a path name of
159 the termcap file to search. If I<TERMCAP> does not begin with a
160 slash and name is different from I<TERM>, B<Tgetent> searches the
161 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
162 in that order, unless the environment variable I<TERMPATH> exists,
163 in which case it specifies a list of file pathnames (separated by
164 spaces or colons) to be searched B<instead>. Whenever multiple
165 files are searched and a tc field occurs in the requested entry,
166 the entry it names must be found in the same file or one of the
167 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
168 environment variable string it will continue the search in the
171 The extracted termcap entry is available in the object
172 as C<$self-E<gt>{TERMCAP}>.
174 It takes a hash reference as an argument with two optional keys:
180 The terminal output bit rate (often mistakenly called the baud rate)
181 for this terminal - if not set a warning will be generated
182 and it will be defaulted to 9600. I<OSPEED> can be be specified as
183 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
184 an old DSD-style speed ( where 13 equals 9600).
189 The terminal type whose termcap entry will be used - if not supplied it will
190 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
194 It calls C<croak> on failure.
199 { ## public -- static method
203 $self = {} unless defined $self;
206 my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
207 local ( $termpat, $state, $first, $entry ); # used inside eval
210 # Compute PADDING factor from OSPEED (to be used by Tpad)
211 if ( !$self->{OSPEED} )
215 carp "OSPEED was not set, defaulting to 9600";
217 $self->{OSPEED} = 9600;
219 if ( $self->{OSPEED} < 16 )
222 # delays for old style speeds
224 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
225 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
227 $self->{PADDING} = $pad[ $self->{OSPEED} ];
231 $self->{PADDING} = 10000 / $self->{OSPEED};
234 unless ( $self->{TERM} )
238 $self->{TERM} = $ENV{TERM} ;
242 if ( $^O eq 'Win32' )
244 $self->{TERM} = 'dumb';
248 croak "TERM not set";
253 $term = $self->{TERM}; # $term is the term type we are looking for
255 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
256 $tmp_term = $self->{TERM};
258 # protect any pattern metacharacters in $tmp_term
259 $termpat = $tmp_term;
260 $termpat =~ s/(\W)/\\$1/g;
262 my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
264 # $entry is the extracted termcap entry
265 if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
270 my @termcap_path = termcap_path();
272 unless ( @termcap_path || $entry )
275 # last resort--fake up a termcap from terminfo
276 local $ENV{TERM} = $term;
280 $entry = $VMS_TERMCAP;
284 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
287 my $tmp = `infocmp -C 2>/dev/null`;
288 $tmp =~ s/^#.*\n//gm; # remove comments
289 if ( ( $tmp !~ m%^/%s )
290 && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
298 # this is getting desperate now
299 if ( $self->{TERM} eq 'dumb' )
301 $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
307 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
309 $state = 1; # 0 == finished
313 $first = 0; # first entry (keeps term name)
315 $max = 32; # max :tc=...:'s
320 # ok, we're starting with $TERMCAP
321 $first++; # we're the first entry
322 # do we need to continue?
323 if ( $entry =~ s/:tc=([^:]+):/:/ )
327 # protect any pattern metacharacters in $tmp_term
328 $termpat = $tmp_term;
329 $termpat =~ s/(\W)/\\$1/g;
333 $state = 0; # we're already finished
337 # This is eval'ed inside the while loop for each file
340 next if /^\\t/ || /^#/;
341 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
343 s/^[^:]*:// if $first++;
345 while ($_ =~ s/\\\\$//) {
346 defined(my $x = <TERMCAP>) or last;
352 defined $entry or $entry = '';
356 while ( $state != 0 )
361 # get the next TERMCAP
362 $TERMCAP = shift @termcap_path
363 || croak "failed termcap lookup on $tmp_term";
368 # do the same file again
369 # prevent endless recursion
370 $max-- || croak "failed termcap loop at $tmp_term";
371 $state = 1; # ok, maybe do a new file next time
374 open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
379 # If :tc=...: found then search this file again
380 $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
382 # protect any pattern metacharacters in $tmp_term
383 $termpat = $tmp_term;
384 $termpat =~ s/(\W)/\\$1/g;
387 croak "Can't find $term" if $entry eq '';
388 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
389 $entry =~ s/:+/:/g; # cleanup $entry
390 $self->{TERMCAP} = $entry; # save it
391 # print STDERR "DEBUG: $entry = ", $entry, "\n";
393 # Precompile $entry into the object
394 $entry =~ s/^[^:]*://;
395 foreach $field ( split( /:[\s:\\]*/, $entry ) )
397 if ( defined $field && $field =~ /^(\w\w)$/ )
399 $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
401 # print STDERR "DEBUG: flag $1\n";
403 elsif ( defined $field && $field =~ /^(\w\w)\@/ )
405 $self->{ '_' . $1 } = "";
407 # print STDERR "DEBUG: unset $1\n";
409 elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
411 $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
413 # print STDERR "DEBUG: numeric $1 = $2\n";
415 elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
418 # print STDERR "DEBUG: string $1 = $2\n";
419 next if defined $self->{ '_' . ( $cap = $1 ) };
422 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
430 s/\^(.)/pack('c',ord($1) & 31)/eg;
433 $self->{ '_' . $cap } = $_;
436 # else { carp "junk in $term ignored: $field"; }
438 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
439 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
443 # $terminal->Tpad($string, $cnt, $FH);
447 Outputs a literal string with appropriate padding for the current terminal.
449 It takes three arguments:
455 The literal string to be output. If it starts with a number and an optional
456 '*' then the padding will be increased by an amount relative to this number,
457 if the '*' is present then this amount will me multiplied by $cnt. This part
458 of $string is removed before output/
462 Will be used to modify the padding applied to string as described above.
466 An optional filehandle (or IO::Handle ) that output will be printed to.
470 The padded $string is returned.
477 my ( $string, $cnt, $FH ) = @_;
480 if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
485 $decr = $self->{PADDING};
489 $string .= $self->{'_pc'} x ( $ms / $decr );
492 print $FH $string if $FH;
496 # $terminal->Tputs($cap, $cnt, $FH);
500 Output the string for the given capability padded as appropriate without
501 any parameter substitution.
503 It takes three arguments:
509 The capability whose string is to be output.
513 A count passed to Tpad to modify the padding applied to the output string.
514 If $cnt is zero or one then the resulting string will be cached.
518 An optional filehandle (or IO::Handle ) that output will be printed to.
522 The appropriate string for the capability will be returned.
529 my ( $cap, $cnt, $FH ) = @_;
532 $cnt = 0 unless $cnt;
536 $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
541 # cache result because Tpad can be slow
542 unless ( exists $self->{$cap} )
545 exists $self->{"_$cap"}
546 ? Tpad( $self, $self->{"_$cap"}, 1 )
549 $string = $self->{$cap};
551 print $FH $string if $FH;
555 # $terminal->Tgoto($cap, $col, $row, $FH);
559 B<Tgoto> decodes a cursor addressing string with the given parameters.
561 There are four arguments:
567 The name of the capability to be output.
571 The first value to be substituted in the output string ( usually the column
572 in a cursor addressing capability )
576 The second value to be substituted in the output string (usually the row
577 in cursor addressing capabilities)
581 An optional filehandle (or IO::Handle ) to which the output string will be
586 Substitutions are made with $col and $row in the output string with the
587 following sprintf() line formats:
590 %d output value as in printf %d
591 %2 output value as in printf %2d
592 %3 output value as in printf %3d
593 %. output value as in printf %c
594 %+x add x to value, then do %.
596 %>xy if value > x then add y, no output
597 %r reverse order of two parameters, no output
598 %i increment by one, no output
599 %B BCD (16*(value/10)) + (value%10), no output
601 %n exclusive-or all parameters with 0140 (Datamedia 2500)
602 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
604 The output string will be returned.
611 my ( $cap, $code, $tmp, $FH ) = @_;
612 my $string = $self->{ '_' . $cap };
616 my @tmp = ( $tmp, $code );
619 while ( $string =~ /^([^%]*)%(.)(.*)/ )
626 $result .= sprintf( "%d", shift(@tmp) );
628 elsif ( $code eq '.' )
631 if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
635 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
639 ++$tmp, $after .= $self->{'_bc'};
642 $result .= sprintf( "%c", $tmp );
645 elsif ( $code eq '+' )
647 $result .= sprintf( "%c", shift(@tmp) + ord($string) );
648 $string = substr( $string, 1, 99 );
651 elsif ( $code eq 'r' )
653 ( $code, $tmp ) = @tmp;
654 @tmp = ( $tmp, $code );
657 elsif ( $code eq '>' )
659 ( $code, $tmp, $string ) = unpack( "CCa99", $string );
660 if ( $tmp[$[] > $code )
665 elsif ( $code eq '2' )
667 $result .= sprintf( "%02d", shift(@tmp) );
670 elsif ( $code eq '3' )
672 $result .= sprintf( "%03d", shift(@tmp) );
675 elsif ( $code eq 'i' )
677 ( $code, $tmp ) = @tmp;
678 @tmp = ( $code + 1, $tmp + 1 );
685 $string = Tpad( $self, $result . $string . $after, $cnt );
686 print $FH $string if $FH;
690 # $terminal->Trequire(qw/ce ku kd/);
694 Takes a list of capabilities as an argument and will croak if one is not
702 my ( $cap, @undefined );
705 push( @undefined, $cap )
706 unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
708 croak "Terminal does not support: (@undefined)" if @undefined;
717 # Get terminal output speed
719 my $termios = new POSIX::Termios;
721 my $ospeed = $termios->getospeed;
723 # Old-style ioctl code to get ospeed:
724 # require 'ioctl.pl';
725 # ioctl(TTY,$TIOCGETP,$sgtty);
726 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
728 # allocate and initialize a terminal structure
729 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
731 # require certain capabilities to be available
732 $terminal->Trequire(qw/ce ku kd/);
734 # Output Routines, if $FH is undefined these just return the string
736 # Tgoto does the % expansion stuff with the given args
737 $terminal->Tgoto('cm', $col, $row, $FH);
739 # Tputs doesn't do any % expansion.
740 $terminal->Tputs('dl', $count = 1, $FH);
742 =head1 COPYRIGHT AND LICENSE
744 Please see the README file in distribution.
748 This module is part of the core Perl distribution and is also maintained
749 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
757 # Below is a default entry for systems where there are terminals but no
761 vt220|vt200|DEC VT220 in vt100 emulation mode:
765 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
766 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
767 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
768 ei=\E[4l:ho=\E[H:im=\E[4h:
771 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
772 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
774 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
775 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
776 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: