1package Term::Cap; 2 3use Carp; 4use strict; 5 6use vars qw($VERSION $VMS_TERMCAP); 7use vars qw($termpat $state $first $entry); 8 9$VERSION = '1.08'; 10 11# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com 12# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com 13# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/ 14# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu 15# Avoid warnings in Tgetent and Tputs 16# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com 17# Altered layout of the POD 18# Added Test::More to PREREQ_PM in Makefile.PL 19# Fixed no argument Tgetent() 20# Version 1.03: Wed Nov 28 10:09:38 GMT 2001 21# VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu> 22# Version 1.04: Thu Nov 29 16:22:03 GMT 2001 23# Fixed warnings in test 24# Version 1.05: Mon Dec 3 15:33:49 GMT 2001 25# Don't try to fall back on infocmp if it's not there. From chromatic. 26# Version 1.06: Thu Dec 6 18:43:22 GMT 2001 27# Preload the default VMS termcap from Charles Lane 28# Don't carp at setting OSPEED unless warnings are on. 29# Version 1.07: Wed Jan 2 21:35:09 GMT 2002 30# Sanity check on infocmp output from Norton Allen 31# Repaired INSTALLDIRS thanks to Michael Schwern 32# Version 1.08: Fri Aug 30 14:15:55 CEST 2002 33# Cope with comments lines from 'infocmp' from Brendan O'Dea 34 35# TODO: 36# support Berkeley DB termcaps 37# should probably be a .xs module 38# force $FH into callers package? 39# keep $FH in object at Tgetent time? 40 41=head1 NAME 42 43Term::Cap - Perl termcap interface 44 45=head1 SYNOPSIS 46 47 require Term::Cap; 48 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; 49 $terminal->Trequire(qw/ce ku kd/); 50 $terminal->Tgoto('cm', $col, $row, $FH); 51 $terminal->Tputs('dl', $count, $FH); 52 $terminal->Tpad($string, $count, $FH); 53 54=head1 DESCRIPTION 55 56These are low-level functions to extract and use capabilities from 57a terminal capability (termcap) database. 58 59More information on the terminal capabilities will be found in the 60termcap manpage on most Unix-like systems. 61 62=head2 METHODS 63 64=over 4 65 66The output strings for B<Tputs> are cached for counts of 1 for performance. 67B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap 68data and C<$self-E<gt>{xx}> is the cached version. 69 70 print $terminal->Tpad($self->{_xx}, 1); 71 72B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also 73output the string to $FH if specified. 74 75 76=cut 77 78# Preload the default VMS termcap. 79# If a different termcap is required then the text of one can be supplied 80# in $Term::Cap::VMS_TERMCAP before Tgetent is called. 81 82if ( $^O eq 'VMS') { 83 chomp (my @entry = <DATA>); 84 $VMS_TERMCAP = join '', @entry; 85} 86 87# Returns a list of termcap files to check. 88 89sub termcap_path { ## private 90 my @termcap_path; 91 # $TERMCAP, if it's a filespec 92 push(@termcap_path, $ENV{TERMCAP}) 93 if ((exists $ENV{TERMCAP}) && 94 (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') 95 ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is 96 : $ENV{TERMCAP} =~ /^\//s)); 97 if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) { 98 # Add the users $TERMPATH 99 push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH})) 100 } 101 else { 102 # Defaults 103 push(@termcap_path, 104 $ENV{'HOME'} . '/.termcap', 105 '/etc/termcap', 106 '/usr/share/misc/termcap', 107 ); 108 } 109 110 # return the list of those termcaps that exist 111 return grep(-f, @termcap_path); 112} 113 114=item B<Tgetent> 115 116Returns a blessed object reference which the user can 117then use to send the control strings to the terminal using B<Tputs> 118and B<Tgoto>. 119 120The function extracts the entry of the specified terminal 121type I<TERM> (defaults to the environment variable I<TERM>) from the 122database. 123 124It will look in the environment for a I<TERMCAP> variable. If 125found, and the value does not begin with a slash, and the terminal 126type name is the same as the environment string I<TERM>, the 127I<TERMCAP> string is used instead of reading a termcap file. If 128it does begin with a slash, the string is used as a path name of 129the termcap file to search. If I<TERMCAP> does not begin with a 130slash and name is different from I<TERM>, B<Tgetent> searches the 131files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>, 132in that order, unless the environment variable I<TERMPATH> exists, 133in which case it specifies a list of file pathnames (separated by 134spaces or colons) to be searched B<instead>. Whenever multiple 135files are searched and a tc field occurs in the requested entry, 136the entry it names must be found in the same file or one of the 137succeeding files. If there is a C<:tc=...:> in the I<TERMCAP> 138environment variable string it will continue the search in the 139files as above. 140 141The extracted termcap entry is available in the object 142as C<$self-E<gt>{TERMCAP}>. 143 144It takes a hash reference as an argument with two optional keys: 145 146=over 2 147 148=item OSPEED 149 150The terminal output bit rate (often mistakenly called the baud rate) 151for this terminal - if not set a warning will be generated 152and it will be defaulted to 9600. I<OSPEED> can be be specified as 153either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or 154an old DSD-style speed ( where 13 equals 9600). 155 156 157=item TERM 158 159The terminal type whose termcap entry will be used - if not supplied it will 160default to $ENV{TERM}: if that is not set then B<Tgetent> will croak. 161 162=back 163 164It calls C<croak> on failure. 165 166=cut 167 168sub Tgetent { ## public -- static method 169 my $class = shift; 170 my ($self) = @_; 171 172 $self = {} unless defined $self; 173 bless $self, $class; 174 175 my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP); 176 local($termpat,$state,$first,$entry); # used inside eval 177 local $_; 178 179 # Compute PADDING factor from OSPEED (to be used by Tpad) 180 if (! $self->{OSPEED}) { 181 if ( $^W ) { 182 carp "OSPEED was not set, defaulting to 9600"; 183 } 184 $self->{OSPEED} = 9600; 185 } 186 if ($self->{OSPEED} < 16) { 187 # delays for old style speeds 188 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); 189 $self->{PADDING} = $pad[$self->{OSPEED}]; 190 } 191 else { 192 $self->{PADDING} = 10000 / $self->{OSPEED}; 193 } 194 195 $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set"); 196 $term = $self->{TERM}; # $term is the term type we are looking for 197 198 # $tmp_term is always the next term (possibly :tc=...:) we are looking for 199 $tmp_term = $self->{TERM}; 200 # protect any pattern metacharacters in $tmp_term 201 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; 202 203 my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : ''); 204 205 # $entry is the extracted termcap entry 206 if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) { 207 $entry = $foo; 208 } 209 210 my @termcap_path = termcap_path(); 211 212 unless (@termcap_path || $entry) 213 { 214 # last resort--fake up a termcap from terminfo 215 local $ENV{TERM} = $term; 216 217 if ( $^O eq 'VMS' ) { 218 $entry = $VMS_TERMCAP; 219 } 220 else { 221 if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) { 222 eval { 223 my $tmp = `infocmp -C 2>/dev/null`; 224 $tmp =~ s/^#.*\n//gm; # remove comments 225 226 if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) { 227 $entry = $tmp; 228 } 229 }; 230 } 231 } 232 } 233 234 croak "Can't find a valid termcap file" unless @termcap_path || $entry; 235 236 $state = 1; # 0 == finished 237 # 1 == next file 238 # 2 == search again 239 240 $first = 0; # first entry (keeps term name) 241 242 $max = 32; # max :tc=...:'s 243 244 if ($entry) { 245 # ok, we're starting with $TERMCAP 246 $first++; # we're the first entry 247 # do we need to continue? 248 if ($entry =~ s/:tc=([^:]+):/:/) { 249 $tmp_term = $1; 250 # protect any pattern metacharacters in $tmp_term 251 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; 252 } 253 else { 254 $state = 0; # we're already finished 255 } 256 } 257 258 # This is eval'ed inside the while loop for each file 259 $search = q{ 260 while (<TERMCAP>) { 261 next if /^\\t/ || /^#/; 262 if ($_ =~ m/(^|\\|)${termpat}[:|]/o) { 263 chomp; 264 s/^[^:]*:// if $first++; 265 $state = 0; 266 while ($_ =~ s/\\\\$//) { 267 defined(my $x = <TERMCAP>) or last; 268 $_ .= $x; chomp; 269 } 270 last; 271 } 272 } 273 defined $entry or $entry = ''; 274 $entry .= $_ if $_; 275 }; 276 277 while ($state != 0) { 278 if ($state == 1) { 279 # get the next TERMCAP 280 $TERMCAP = shift @termcap_path 281 || croak "failed termcap lookup on $tmp_term"; 282 } 283 else { 284 # do the same file again 285 # prevent endless recursion 286 $max-- || croak "failed termcap loop at $tmp_term"; 287 $state = 1; # ok, maybe do a new file next time 288 } 289 290 open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!"; 291 eval $search; 292 die $@ if $@; 293 close TERMCAP; 294 295 # If :tc=...: found then search this file again 296 $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2); 297 # protect any pattern metacharacters in $tmp_term 298 $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; 299 } 300 301 croak "Can't find $term" if $entry eq ''; 302 $entry =~ s/:+\s*:+/:/g; # cleanup $entry 303 $entry =~ s/:+/:/g; # cleanup $entry 304 $self->{TERMCAP} = $entry; # save it 305 # print STDERR "DEBUG: $entry = ", $entry, "\n"; 306 307 # Precompile $entry into the object 308 $entry =~ s/^[^:]*://; 309 foreach $field (split(/:[\s:\\]*/,$entry)) { 310 if (defined $field && $field =~ /^(\w\w)$/) { 311 $self->{'_' . $field} = 1 unless defined $self->{'_' . $1}; 312 # print STDERR "DEBUG: flag $1\n"; 313 } 314 elsif (defined $field && $field =~ /^(\w\w)\@/) { 315 $self->{'_' . $1} = ""; 316 # print STDERR "DEBUG: unset $1\n"; 317 } 318 elsif (defined $field && $field =~ /^(\w\w)#(.*)/) { 319 $self->{'_' . $1} = $2 unless defined $self->{'_' . $1}; 320 # print STDERR "DEBUG: numeric $1 = $2\n"; 321 } 322 elsif (defined $field && $field =~ /^(\w\w)=(.*)/) { 323 # print STDERR "DEBUG: string $1 = $2\n"; 324 next if defined $self->{'_' . ($cap = $1)}; 325 $_ = $2; 326 s/\\E/\033/g; 327 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; 328 s/\\n/\n/g; 329 s/\\r/\r/g; 330 s/\\t/\t/g; 331 s/\\b/\b/g; 332 s/\\f/\f/g; 333 s/\\\^/\377/g; 334 s/\^\?/\177/g; 335 s/\^(.)/pack('c',ord($1) & 31)/eg; 336 s/\\(.)/$1/g; 337 s/\377/^/g; 338 $self->{'_' . $cap} = $_; 339 } 340 # else { carp "junk in $term ignored: $field"; } 341 } 342 $self->{'_pc'} = "\0" unless defined $self->{'_pc'}; 343 $self->{'_bc'} = "\b" unless defined $self->{'_bc'}; 344 $self; 345} 346 347# $terminal->Tpad($string, $cnt, $FH); 348 349=item B<Tpad> 350 351Outputs a literal string with appropriate padding for the current terminal. 352 353It takes three arguments: 354 355=over 2 356 357=item B<$string> 358 359The literal string to be output. If it starts with a number and an optional 360'*' then the padding will be increased by an amount relative to this number, 361if the '*' is present then this amount will me multiplied by $cnt. This part 362of $string is removed before output/ 363 364=item B<$cnt> 365 366Will be used to modify the padding applied to string as described above. 367 368=item B<$FH> 369 370An optional filehandle (or IO::Handle ) that output will be printed to. 371 372=back 373 374The padded $string is returned. 375 376=cut 377 378sub Tpad { ## public 379 my $self = shift; 380 my($string, $cnt, $FH) = @_; 381 my($decr, $ms); 382 383 if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) { 384 $ms = $1; 385 $ms *= $cnt if $2; 386 $string = $3; 387 $decr = $self->{PADDING}; 388 if ($decr > .1) { 389 $ms += $decr / 2; 390 $string .= $self->{'_pc'} x ($ms / $decr); 391 } 392 } 393 print $FH $string if $FH; 394 $string; 395} 396 397# $terminal->Tputs($cap, $cnt, $FH); 398 399=item B<Tputs> 400 401Output the string for the given capability padded as appropriate without 402any parameter substitution. 403 404It takes three arguments: 405 406=over 2 407 408=item B<$cap> 409 410The capability whose string is to be output. 411 412=item B<$cnt> 413 414A count passed to Tpad to modify the padding applied to the output string. 415If $cnt is zero or one then the resulting string will be cached. 416 417=item B<$FH> 418 419An optional filehandle (or IO::Handle ) that output will be printed to. 420 421=back 422 423The appropriate string for the capability will be returned. 424 425=cut 426 427sub Tputs { ## public 428 my $self = shift; 429 my($cap, $cnt, $FH) = @_; 430 my $string; 431 432 $cnt = 0 unless $cnt; 433 434 if ($cnt > 1) { 435 $string = Tpad($self, $self->{'_' . $cap}, $cnt); 436 } else { 437 # cache result because Tpad can be slow 438 unless (exists $self->{$cap}) { 439 $self->{$cap} = exists $self->{"_$cap"} ? 440 Tpad($self, $self->{"_$cap"}, 1) : undef; 441 } 442 $string = $self->{$cap}; 443 } 444 print $FH $string if $FH; 445 $string; 446} 447 448# $terminal->Tgoto($cap, $col, $row, $FH); 449 450=item B<Tgoto> 451 452B<Tgoto> decodes a cursor addressing string with the given parameters. 453 454There are four arguments: 455 456=over 2 457 458=item B<$cap> 459 460The name of the capability to be output. 461 462=item B<$col> 463 464The first value to be substituted in the output string ( usually the column 465in a cursor addressing capability ) 466 467=item B<$row> 468 469The second value to be substituted in the output string (usually the row 470in cursor addressing capabilities) 471 472=item B<$FH> 473 474An optional filehandle (or IO::Handle ) to which the output string will be 475printed. 476 477=back 478 479Substitutions are made with $col and $row in the output string with the 480following sprintf() line formats: 481 482 %% output `%' 483 %d output value as in printf %d 484 %2 output value as in printf %2d 485 %3 output value as in printf %3d 486 %. output value as in printf %c 487 %+x add x to value, then do %. 488 489 %>xy if value > x then add y, no output 490 %r reverse order of two parameters, no output 491 %i increment by one, no output 492 %B BCD (16*(value/10)) + (value%10), no output 493 494 %n exclusive-or all parameters with 0140 (Datamedia 2500) 495 %D Reverse coding (value - 2*(value%16)), no output (Delta Data) 496 497The output string will be returned. 498 499=cut 500 501sub Tgoto { ## public 502 my $self = shift; 503 my($cap, $code, $tmp, $FH) = @_; 504 my $string = $self->{'_' . $cap}; 505 my $result = ''; 506 my $after = ''; 507 my $online = 0; 508 my @tmp = ($tmp,$code); 509 my $cnt = $code; 510 511 while ($string =~ /^([^%]*)%(.)(.*)/) { 512 $result .= $1; 513 $code = $2; 514 $string = $3; 515 if ($code eq 'd') { 516 $result .= sprintf("%d",shift(@tmp)); 517 } 518 elsif ($code eq '.') { 519 $tmp = shift(@tmp); 520 if ($tmp == 0 || $tmp == 4 || $tmp == 10) { 521 if ($online) { 522 ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; 523 } 524 else { 525 ++$tmp, $after .= $self->{'_bc'}; 526 } 527 } 528 $result .= sprintf("%c",$tmp); 529 $online = !$online; 530 } 531 elsif ($code eq '+') { 532 $result .= sprintf("%c",shift(@tmp)+ord($string)); 533 $string = substr($string,1,99); 534 $online = !$online; 535 } 536 elsif ($code eq 'r') { 537 ($code,$tmp) = @tmp; 538 @tmp = ($tmp,$code); 539 $online = !$online; 540 } 541 elsif ($code eq '>') { 542 ($code,$tmp,$string) = unpack("CCa99",$string); 543 if ($tmp[$[] > $code) { 544 $tmp[$[] += $tmp; 545 } 546 } 547 elsif ($code eq '2') { 548 $result .= sprintf("%02d",shift(@tmp)); 549 $online = !$online; 550 } 551 elsif ($code eq '3') { 552 $result .= sprintf("%03d",shift(@tmp)); 553 $online = !$online; 554 } 555 elsif ($code eq 'i') { 556 ($code,$tmp) = @tmp; 557 @tmp = ($code+1,$tmp+1); 558 } 559 else { 560 return "OOPS"; 561 } 562 } 563 $string = Tpad($self, $result . $string . $after, $cnt); 564 print $FH $string if $FH; 565 $string; 566} 567 568# $terminal->Trequire(qw/ce ku kd/); 569 570=item B<Trequire> 571 572Takes a list of capabilities as an argument and will croak if one is not 573found. 574 575=cut 576 577sub Trequire { ## public 578 my $self = shift; 579 my($cap,@undefined); 580 foreach $cap (@_) { 581 push(@undefined, $cap) 582 unless defined $self->{'_' . $cap} && $self->{'_' . $cap}; 583 } 584 croak "Terminal does not support: (@undefined)" if @undefined; 585} 586 587=back 588 589=head1 EXAMPLES 590 591 use Term::Cap; 592 593 # Get terminal output speed 594 require POSIX; 595 my $termios = new POSIX::Termios; 596 $termios->getattr; 597 my $ospeed = $termios->getospeed; 598 599 # Old-style ioctl code to get ospeed: 600 # require 'ioctl.pl'; 601 # ioctl(TTY,$TIOCGETP,$sgtty); 602 # ($ispeed,$ospeed) = unpack('cc',$sgtty); 603 604 # allocate and initialize a terminal structure 605 $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; 606 607 # require certain capabilities to be available 608 $terminal->Trequire(qw/ce ku kd/); 609 610 # Output Routines, if $FH is undefined these just return the string 611 612 # Tgoto does the % expansion stuff with the given args 613 $terminal->Tgoto('cm', $col, $row, $FH); 614 615 # Tputs doesn't do any % expansion. 616 $terminal->Tputs('dl', $count = 1, $FH); 617 618=head1 COPYRIGHT AND LICENSE 619 620Please see the README file in distribution. 621 622=head1 AUTHOR 623 624This module is part of the core Perl distribution and is also maintained 625for CPAN by Jonathan Stowe <jns@gellyfish.com>. 626 627=head1 SEE ALSO 628 629termcap(5) 630 631=cut 632 633# Below is a default entry for systems where there are terminals but no 634# termcap 6351; 636__DATA__ 637vt220|vt200|DEC VT220 in vt100 emulation mode: 638am:mi:xn:xo: 639co#80:li#24: 640RA=\E[?7l:SA=\E[?7h: 641ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0: 642bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH: 643cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B: 644ei=\E[4l:ho=\E[H:im=\E[4h: 645is=\E[1;24r\E[24;1H: 646nd=\E[C: 647kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H: 648mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m: 649kb=\0177: 650r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8: 651sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I: 652ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: 653 654