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