[Summary view] [Print] [Text view]

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