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