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