lib/Term/Cap.pm

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