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>
60 # support Berkeley DB termcaps
61 # force $FH into callers package?
62 # keep $FH in object at Tgetent time?
66 Term::Cap - Perl termcap interface
71 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
72 $terminal->Trequire(qw/ce ku kd/);
73 $terminal->Tgoto('cm', $col, $row, $FH);
74 $terminal->Tputs('dl', $count, $FH);
75 $terminal->Tpad($string, $count, $FH);
79 These are low-level functions to extract and use capabilities from
80 a terminal capability (termcap) database.
82 More information on the terminal capabilities will be found in the
83 termcap manpage on most Unix-like systems.
89 The output strings for B<Tputs> are cached for counts of 1 for performance.
90 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
91 data and C<$self-E<gt>{xx}> is the cached version.
93 print $terminal->Tpad($self->{_xx}, 1);
95 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
96 output the string to $FH if specified.
101 # Preload the default VMS termcap.
102 # If a different termcap is required then the text of one can be supplied
103 # in $Term::Cap::VMS_TERMCAP before Tgetent is called.
107 chomp( my @entry = <DATA> );
108 $VMS_TERMCAP = join '', @entry;
111 # Returns a list of termcap files to check.
117 # $TERMCAP, if it's a filespec
118 push( @termcap_path, $ENV{TERMCAP} )
120 ( exists $ENV{TERMCAP} )
122 ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
123 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
124 : $ENV{TERMCAP} =~ /^\//s
127 if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
130 # Add the users $TERMPATH
131 push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
138 exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
139 '/etc/termcap', '/usr/share/misc/termcap', );
142 # return the list of those termcaps that exist
143 return grep { defined $_ && -f $_ } @termcap_path;
148 Returns a blessed object reference which the user can
149 then use to send the control strings to the terminal using B<Tputs>
152 The function extracts the entry of the specified terminal
153 type I<TERM> (defaults to the environment variable I<TERM>) from the
156 It will look in the environment for a I<TERMCAP> variable. If
157 found, and the value does not begin with a slash, and the terminal
158 type name is the same as the environment string I<TERM>, the
159 I<TERMCAP> string is used instead of reading a termcap file. If
160 it does begin with a slash, the string is used as a path name of
161 the termcap file to search. If I<TERMCAP> does not begin with a
162 slash and name is different from I<TERM>, B<Tgetent> searches the
163 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
164 in that order, unless the environment variable I<TERMPATH> exists,
165 in which case it specifies a list of file pathnames (separated by
166 spaces or colons) to be searched B<instead>. Whenever multiple
167 files are searched and a tc field occurs in the requested entry,
168 the entry it names must be found in the same file or one of the
169 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
170 environment variable string it will continue the search in the
173 The extracted termcap entry is available in the object
174 as C<$self-E<gt>{TERMCAP}>.
176 It takes a hash reference as an argument with two optional keys:
182 The terminal output bit rate (often mistakenly called the baud rate)
183 for this terminal - if not set a warning will be generated
184 and it will be defaulted to 9600. I<OSPEED> can be be specified as
185 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
186 an old DSD-style speed ( where 13 equals 9600).
191 The terminal type whose termcap entry will be used - if not supplied it will
192 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
196 It calls C<croak> on failure.
201 { ## public -- static method
205 $self = {} unless defined $self;
208 my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
209 local ( $termpat, $state, $first, $entry ); # used inside eval
212 # Compute PADDING factor from OSPEED (to be used by Tpad)
213 if ( !$self->{OSPEED} )
217 carp "OSPEED was not set, defaulting to 9600";
219 $self->{OSPEED} = 9600;
221 if ( $self->{OSPEED} < 16 )
224 # delays for old style speeds
226 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
227 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
229 $self->{PADDING} = $pad[ $self->{OSPEED} ];
233 $self->{PADDING} = 10000 / $self->{OSPEED};
236 unless ( $self->{TERM} )
240 $self->{TERM} = $ENV{TERM} ;
244 if ( $^O eq 'Win32' )
246 $self->{TERM} = 'dumb';
250 croak "TERM not set";
255 $term = $self->{TERM}; # $term is the term type we are looking for
257 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
258 $tmp_term = $self->{TERM};
260 # protect any pattern metacharacters in $tmp_term
261 $termpat = $tmp_term;
262 $termpat =~ s/(\W)/\\$1/g;
264 my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
266 # $entry is the extracted termcap entry
267 if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
272 my @termcap_path = termcap_path();
274 unless ( @termcap_path || $entry )
277 # last resort--fake up a termcap from terminfo
278 local $ENV{TERM} = $term;
282 $entry = $VMS_TERMCAP;
286 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
289 my $tmp = `infocmp -C 2>/dev/null`;
290 $tmp =~ s/^#.*\n//gm; # remove comments
291 if ( ( $tmp !~ m%^/%s )
292 && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
300 # this is getting desperate now
301 if ( $self->{TERM} eq 'dumb' )
303 $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
309 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
311 $state = 1; # 0 == finished
315 $first = 0; # first entry (keeps term name)
317 $max = 32; # max :tc=...:'s
322 # ok, we're starting with $TERMCAP
323 $first++; # we're the first entry
324 # do we need to continue?
325 if ( $entry =~ s/:tc=([^:]+):/:/ )
329 # protect any pattern metacharacters in $tmp_term
330 $termpat = $tmp_term;
331 $termpat =~ s/(\W)/\\$1/g;
335 $state = 0; # we're already finished
339 # This is eval'ed inside the while loop for each file
342 next if /^\\t/ || /^#/;
343 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
345 s/^[^:]*:// if $first++;
347 while ($_ =~ s/\\\\$//) {
348 defined(my $x = <TERMCAP>) or last;
354 defined $entry or $entry = '';
358 while ( $state != 0 )
363 # get the next TERMCAP
364 $TERMCAP = shift @termcap_path
365 || croak "failed termcap lookup on $tmp_term";
370 # do the same file again
371 # prevent endless recursion
372 $max-- || croak "failed termcap loop at $tmp_term";
373 $state = 1; # ok, maybe do a new file next time
376 open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
381 # If :tc=...: found then search this file again
382 $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
384 # protect any pattern metacharacters in $tmp_term
385 $termpat = $tmp_term;
386 $termpat =~ s/(\W)/\\$1/g;
389 croak "Can't find $term" if $entry eq '';
390 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
391 $entry =~ s/:+/:/g; # cleanup $entry
392 $self->{TERMCAP} = $entry; # save it
393 # print STDERR "DEBUG: $entry = ", $entry, "\n";
395 # Precompile $entry into the object
396 $entry =~ s/^[^:]*://;
397 foreach $field ( split( /:[\s:\\]*/, $entry ) )
399 if ( defined $field && $field =~ /^(\w\w)$/ )
401 $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
403 # print STDERR "DEBUG: flag $1\n";
405 elsif ( defined $field && $field =~ /^(\w\w)\@/ )
407 $self->{ '_' . $1 } = "";
409 # print STDERR "DEBUG: unset $1\n";
411 elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ )
413 $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
415 # print STDERR "DEBUG: numeric $1 = $2\n";
417 elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ )
420 # print STDERR "DEBUG: string $1 = $2\n";
421 next if defined $self->{ '_' . ( $cap = $1 ) };
423 if ( ord('A') == 193 )
426 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
434 s/\^(.)/pack('c',ord($1) & 31)/eg;
441 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
449 s/\^(.)/pack('c',ord($1) & 31)/eg;
453 $self->{ '_' . $cap } = $_;
456 # else { carp "junk in $term ignored: $field"; }
458 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
459 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
463 # $terminal->Tpad($string, $cnt, $FH);
467 Outputs a literal string with appropriate padding for the current terminal.
469 It takes three arguments:
475 The literal string to be output. If it starts with a number and an optional
476 '*' then the padding will be increased by an amount relative to this number,
477 if the '*' is present then this amount will me multiplied by $cnt. This part
478 of $string is removed before output/
482 Will be used to modify the padding applied to string as described above.
486 An optional filehandle (or IO::Handle ) that output will be printed to.
490 The padded $string is returned.
497 my ( $string, $cnt, $FH ) = @_;
500 if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
505 $decr = $self->{PADDING};
509 $string .= $self->{'_pc'} x ( $ms / $decr );
512 print $FH $string if $FH;
516 # $terminal->Tputs($cap, $cnt, $FH);
520 Output the string for the given capability padded as appropriate without
521 any parameter substitution.
523 It takes three arguments:
529 The capability whose string is to be output.
533 A count passed to Tpad to modify the padding applied to the output string.
534 If $cnt is zero or one then the resulting string will be cached.
538 An optional filehandle (or IO::Handle ) that output will be printed to.
542 The appropriate string for the capability will be returned.
549 my ( $cap, $cnt, $FH ) = @_;
552 $cnt = 0 unless $cnt;
556 $string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
561 # cache result because Tpad can be slow
562 unless ( exists $self->{$cap} )
565 exists $self->{"_$cap"}
566 ? Tpad( $self, $self->{"_$cap"}, 1 )
569 $string = $self->{$cap};
571 print $FH $string if $FH;
575 # $terminal->Tgoto($cap, $col, $row, $FH);
579 B<Tgoto> decodes a cursor addressing string with the given parameters.
581 There are four arguments:
587 The name of the capability to be output.
591 The first value to be substituted in the output string ( usually the column
592 in a cursor addressing capability )
596 The second value to be substituted in the output string (usually the row
597 in cursor addressing capabilities)
601 An optional filehandle (or IO::Handle ) to which the output string will be
606 Substitutions are made with $col and $row in the output string with the
607 following sprintf() line formats:
610 %d output value as in printf %d
611 %2 output value as in printf %2d
612 %3 output value as in printf %3d
613 %. output value as in printf %c
614 %+x add x to value, then do %.
616 %>xy if value > x then add y, no output
617 %r reverse order of two parameters, no output
618 %i increment by one, no output
619 %B BCD (16*(value/10)) + (value%10), no output
621 %n exclusive-or all parameters with 0140 (Datamedia 2500)
622 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
624 The output string will be returned.
631 my ( $cap, $code, $tmp, $FH ) = @_;
632 my $string = $self->{ '_' . $cap };
636 my @tmp = ( $tmp, $code );
639 while ( $string =~ /^([^%]*)%(.)(.*)/ )
646 $result .= sprintf( "%d", shift(@tmp) );
648 elsif ( $code eq '.' )
651 if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
655 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
659 ++$tmp, $after .= $self->{'_bc'};
662 $result .= sprintf( "%c", $tmp );
665 elsif ( $code eq '+' )
667 $result .= sprintf( "%c", shift(@tmp) + ord($string) );
668 $string = substr( $string, 1, 99 );
671 elsif ( $code eq 'r' )
673 ( $code, $tmp ) = @tmp;
674 @tmp = ( $tmp, $code );
677 elsif ( $code eq '>' )
679 ( $code, $tmp, $string ) = unpack( "CCa99", $string );
680 if ( $tmp[$[] > $code )
685 elsif ( $code eq '2' )
687 $result .= sprintf( "%02d", shift(@tmp) );
690 elsif ( $code eq '3' )
692 $result .= sprintf( "%03d", shift(@tmp) );
695 elsif ( $code eq 'i' )
697 ( $code, $tmp ) = @tmp;
698 @tmp = ( $code + 1, $tmp + 1 );
705 $string = Tpad( $self, $result . $string . $after, $cnt );
706 print $FH $string if $FH;
710 # $terminal->Trequire(qw/ce ku kd/);
714 Takes a list of capabilities as an argument and will croak if one is not
722 my ( $cap, @undefined );
725 push( @undefined, $cap )
726 unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
728 croak "Terminal does not support: (@undefined)" if @undefined;
737 # Get terminal output speed
739 my $termios = new POSIX::Termios;
741 my $ospeed = $termios->getospeed;
743 # Old-style ioctl code to get ospeed:
744 # require 'ioctl.pl';
745 # ioctl(TTY,$TIOCGETP,$sgtty);
746 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
748 # allocate and initialize a terminal structure
749 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
751 # require certain capabilities to be available
752 $terminal->Trequire(qw/ce ku kd/);
754 # Output Routines, if $FH is undefined these just return the string
756 # Tgoto does the % expansion stuff with the given args
757 $terminal->Tgoto('cm', $col, $row, $FH);
759 # Tputs doesn't do any % expansion.
760 $terminal->Tputs('dl', $count = 1, $FH);
762 =head1 COPYRIGHT AND LICENSE
764 Please see the README file in distribution.
768 This module is part of the core Perl distribution and is also maintained
769 for CPAN by Jonathan Stowe <jns@gellyfish.com>.
777 # Below is a default entry for systems where there are terminals but no
781 vt220|vt200|DEC VT220 in vt100 emulation mode:
785 ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
786 bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
787 cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
788 ei=\E[4l:ho=\E[H:im=\E[4h:
791 kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
792 mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
794 r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
795 sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
796 ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: