9 # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
10 # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
11 # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
12 # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
13 # Avoid warnings in Tgetent and Tputs
14 # Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com
15 # Altered layout of the POD
16 # Added Test::More to PREREQ_PM in Makefile.PL
17 # Fixed no argument Tgetent()
20 # support Berkeley DB termcaps
21 # should probably be a .xs module
22 # force $FH into callers package?
23 # keep $FH in object at Tgetent time?
27 Term::Cap - Perl termcap interface
32 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
33 $terminal->Trequire(qw/ce ku kd/);
34 $terminal->Tgoto('cm', $col, $row, $FH);
35 $terminal->Tputs('dl', $count, $FH);
36 $terminal->Tpad($string, $count, $FH);
40 These are low-level functions to extract and use capabilities from
41 a terminal capability (termcap) database.
43 More information on the terminal capabilities will be found in the
44 termcap manpage on most Unix-like systems.
50 The output strings for B<Tputs> are cached for counts of 1 for performance.
51 B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
52 data and C<$self-E<gt>{xx}> is the cached version.
54 print $terminal->Tpad($self->{_xx}, 1);
56 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
57 output the string to $FH if specified.
62 # Returns a list of termcap files to check.
63 sub termcap_path { ## private
65 # $TERMCAP, if it's a filespec
66 push(@termcap_path, $ENV{TERMCAP})
67 if ((exists $ENV{TERMCAP}) &&
68 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
69 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
70 : $ENV{TERMCAP} =~ /^\//s));
71 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
72 # Add the users $TERMPATH
73 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
78 $ENV{'HOME'} . '/.termcap',
80 '/usr/share/misc/termcap',
83 # return the list of those termcaps that exist
84 return grep(-f, @termcap_path);
89 Returns a blessed object reference which the user can
90 then use to send the control strings to the terminal using B<Tputs>
93 The function extracts the entry of the specified terminal
94 type I<TERM> (defaults to the environment variable I<TERM>) from the
97 It will look in the environment for a I<TERMCAP> variable. If
98 found, and the value does not begin with a slash, and the terminal
99 type name is the same as the environment string I<TERM>, the
100 I<TERMCAP> string is used instead of reading a termcap file. If
101 it does begin with a slash, the string is used as a path name of
102 the termcap file to search. If I<TERMCAP> does not begin with a
103 slash and name is different from I<TERM>, B<Tgetent> searches the
104 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
105 in that order, unless the environment variable I<TERMPATH> exists,
106 in which case it specifies a list of file pathnames (separated by
107 spaces or colons) to be searched B<instead>. Whenever multiple
108 files are searched and a tc field occurs in the requested entry,
109 the entry it names must be found in the same file or one of the
110 succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
111 environment variable string it will continue the search in the
114 The extracted termcap entry is available in the object
115 as C<$self-E<gt>{TERMCAP}>.
117 It takes a hash reference as an argument with two optional keys:
123 The terminal output bit rate (often mistakenly called the baud rate)
124 for this terminal - if not set a warning will be generated
125 and it will be defaulted to 9600. I<OSPEED> can be be specified as
126 either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
127 an old DSD-style speed ( where 13 equals 9600).
132 The terminal type whose termcap entry will be used - if not supplied it will
133 default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
137 It calls C<croak> on failure.
141 sub Tgetent { ## public -- static method
145 $self = {} unless defined $self;
148 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
149 local($termpat,$state,$first,$entry); # used inside eval
152 # Compute PADDING factor from OSPEED (to be used by Tpad)
153 if (! $self->{OSPEED}) {
154 carp "OSPEED was not set, defaulting to 9600";
155 $self->{OSPEED} = 9600;
157 if ($self->{OSPEED} < 16) {
158 # delays for old style speeds
159 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);
160 $self->{PADDING} = $pad[$self->{OSPEED}];
163 $self->{PADDING} = 10000 / $self->{OSPEED};
166 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
167 $term = $self->{TERM}; # $term is the term type we are looking for
169 # $tmp_term is always the next term (possibly :tc=...:) we are looking for
170 $tmp_term = $self->{TERM};
171 # protect any pattern metacharacters in $tmp_term
172 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
174 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
176 # $entry is the extracted termcap entry
177 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
181 my @termcap_path = termcap_path();
183 unless (@termcap_path || $entry)
185 # last resort--fake up a termcap from terminfo
186 local $ENV{TERM} = $term;
189 $entry = `infocmp -C 2>/dev/null`;
193 croak "Can't find a valid termcap file" unless @termcap_path || $entry;
195 $state = 1; # 0 == finished
199 $first = 0; # first entry (keeps term name)
201 $max = 32; # max :tc=...:'s
204 # ok, we're starting with $TERMCAP
205 $first++; # we're the first entry
206 # do we need to continue?
207 if ($entry =~ s/:tc=([^:]+):/:/) {
209 # protect any pattern metacharacters in $tmp_term
210 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
213 $state = 0; # we're already finished
217 # This is eval'ed inside the while loop for each file
220 next if /^\\t/ || /^#/;
221 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
223 s/^[^:]*:// if $first++;
225 while ($_ =~ s/\\\\$//) {
226 defined(my $x = <TERMCAP>) or last;
232 defined $entry or $entry = '';
236 while ($state != 0) {
238 # get the next TERMCAP
239 $TERMCAP = shift @termcap_path
240 || croak "failed termcap lookup on $tmp_term";
243 # do the same file again
244 # prevent endless recursion
245 $max-- || croak "failed termcap loop at $tmp_term";
246 $state = 1; # ok, maybe do a new file next time
249 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
254 # If :tc=...: found then search this file again
255 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
256 # protect any pattern metacharacters in $tmp_term
257 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
260 croak "Can't find $term" if $entry eq '';
261 $entry =~ s/:+\s*:+/:/g; # cleanup $entry
262 $entry =~ s/:+/:/g; # cleanup $entry
263 $self->{TERMCAP} = $entry; # save it
264 # print STDERR "DEBUG: $entry = ", $entry, "\n";
266 # Precompile $entry into the object
267 $entry =~ s/^[^:]*://;
268 foreach $field (split(/:[\s:\\]*/,$entry)) {
269 if ($field =~ /^(\w\w)$/) {
270 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
271 # print STDERR "DEBUG: flag $1\n";
273 elsif ($field =~ /^(\w\w)\@/) {
274 $self->{'_' . $1} = "";
275 # print STDERR "DEBUG: unset $1\n";
277 elsif ($field =~ /^(\w\w)#(.*)/) {
278 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
279 # print STDERR "DEBUG: numeric $1 = $2\n";
281 elsif ($field =~ /^(\w\w)=(.*)/) {
282 # print STDERR "DEBUG: string $1 = $2\n";
283 next if defined $self->{'_' . ($cap = $1)};
286 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
294 s/\^(.)/pack('c',ord($1) & 31)/eg;
297 $self->{'_' . $cap} = $_;
299 # else { carp "junk in $term ignored: $field"; }
301 $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
302 $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
306 # $terminal->Tpad($string, $cnt, $FH);
310 Outputs a literal string with appropriate padding for the current terminal.
312 It takes three arguments:
318 The literal string to be output. If it starts with a number and an optional
319 '*' then the padding will be increased by an amount relative to this number,
320 if the '*' is present then this amount will me multiplied by $cnt. This part
321 of $string is removed before output/
325 Will be used to modify the padding applied to string as described above.
329 An optional filehandle (or IO::Handle ) that output will be printed to.
333 The padded $string is returned.
339 my($string, $cnt, $FH) = @_;
342 if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
346 $decr = $self->{PADDING};
349 $string .= $self->{'_pc'} x ($ms / $decr);
352 print $FH $string if $FH;
356 # $terminal->Tputs($cap, $cnt, $FH);
360 Output the string for the given capability padded as appropriate without
361 any parameter substitution.
363 It takes three arguments:
369 The capability whose string is to be output.
373 A count passed to Tpad to modify the padding applied to the output string.
374 If $cnt is zero or one then the resulting string will be cached.
378 An optional filehandle (or IO::Handle ) that output will be printed to.
382 The appropriate string for the capability will be returned.
386 sub Tputs { ## public
388 my($cap, $cnt, $FH) = @_;
391 $cnt = 0 unless $cnt;
394 $string = Tpad($self, $self->{'_' . $cap}, $cnt);
396 # cache result because Tpad can be slow
397 unless (exists $self->{$cap}) {
398 $self->{$cap} = exists $self->{"_$cap"} ?
399 Tpad($self, $self->{"_$cap"}, 1) : undef;
401 $string = $self->{$cap};
403 print $FH $string if $FH;
407 # $terminal->Tgoto($cap, $col, $row, $FH);
411 B<Tgoto> decodes a cursor addressing string with the given parameters.
413 There are four arguments:
419 The name of the capability to be output.
423 The first value to be substituted in the output string ( usually the column
424 in a cursor addressing capability )
428 The second value to be substituted in the output string (usually the row
429 in cursor addressing capabilities)
433 An optional filehandle (or IO::Handle ) to which the output string will be
438 Substitutions are made with $col and $row in the output string with the
439 following sprintf() line formats:
442 %d output value as in printf %d
443 %2 output value as in printf %2d
444 %3 output value as in printf %3d
445 %. output value as in printf %c
446 %+x add x to value, then do %.
448 %>xy if value > x then add y, no output
449 %r reverse order of two parameters, no output
450 %i increment by one, no output
451 %B BCD (16*(value/10)) + (value%10), no output
453 %n exclusive-or all parameters with 0140 (Datamedia 2500)
454 %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
456 The output string will be returned.
460 sub Tgoto { ## public
462 my($cap, $code, $tmp, $FH) = @_;
463 my $string = $self->{'_' . $cap};
467 my @tmp = ($tmp,$code);
470 while ($string =~ /^([^%]*)%(.)(.*)/) {
475 $result .= sprintf("%d",shift(@tmp));
477 elsif ($code eq '.') {
479 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
481 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
484 ++$tmp, $after .= $self->{'_bc'};
487 $result .= sprintf("%c",$tmp);
490 elsif ($code eq '+') {
491 $result .= sprintf("%c",shift(@tmp)+ord($string));
492 $string = substr($string,1,99);
495 elsif ($code eq 'r') {
500 elsif ($code eq '>') {
501 ($code,$tmp,$string) = unpack("CCa99",$string);
502 if ($tmp[$[] > $code) {
506 elsif ($code eq '2') {
507 $result .= sprintf("%02d",shift(@tmp));
510 elsif ($code eq '3') {
511 $result .= sprintf("%03d",shift(@tmp));
514 elsif ($code eq 'i') {
516 @tmp = ($code+1,$tmp+1);
522 $string = Tpad($self, $result . $string . $after, $cnt);
523 print $FH $string if $FH;
527 # $terminal->Trequire(qw/ce ku kd/);
531 Takes a list of capabilities as an argument and will croak if one is not
536 sub Trequire { ## public
540 push(@undefined, $cap)
541 unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
543 croak "Terminal does not support: (@undefined)" if @undefined;
555 # Get terminal output speed
557 my $termios = new POSIX::Termios;
559 my $ospeed = $termios->getospeed;
561 # Old-style ioctl code to get ospeed:
562 # require 'ioctl.pl';
563 # ioctl(TTY,$TIOCGETP,$sgtty);
564 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
566 # allocate and initialize a terminal structure
567 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
569 # require certain capabilities to be available
570 $terminal->Trequire(qw/ce ku kd/);
572 # Output Routines, if $FH is undefined these just return the string
574 # Tgoto does the % expansion stuff with the given args
575 $terminal->Tgoto('cm', $col, $row, $FH);
577 # Tputs doesn't do any % expansion.
578 $terminal->Tputs('dl', $count = 1, $FH);
580 =head1 COPYRIGHT AND LICENSE
582 Please see the README file in distribution.
586 This module is part of the core Perl distribution and is also maintained
587 for CPAN by Jonathan Stowe <jns@gellyfish.com>.