lib/Term/Cap.pm

   1 # Term::Cap.pm -- Termcap interface routines
   2 package Term::Cap;
   3
   4 # Converted to package on 25 Feb 1994 <sanders@bsdi.com>
   5 #
   6 # Usage:
   7 #       require 'ioctl.pl';
   8 #       ioctl(TTY,$TIOCGETP,$sgtty);
   9 #       ($ispeed,$ospeed) = unpack('cc',$sgtty);
  10 #
  11 #       require Term::Cap;
  12 #
  13 #       $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
  14 #               sets $term->{'_cm'}, etc.
  15 #       $this->Trequire(qw/ce ku kd/);
  16 #               die unless entries are defined for the terminal
  17 #       $term->Tgoto('cm', $col, $row, $FH);
  18 #       $term->Tputs('dl', $cnt = 1, $FH);
  19 #       $this->Tpad($string, $cnt = 1, $FH);
  20 #               processes a termcap string and adds padding if needed
  21 #               if $FH is undefined these just return the string
  22 #
  23 # CHANGES:
  24 #       Converted to package
  25 #       Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
  26 #       Now die's properly if it can't open $TERMCAP or if the eval $loop fails
  27 #       Tputs() results are cached (use Tgoto or Tpad to avoid)
  28 #       Tgoto() will do output if $FH is passed (like Tputs without caching)
  29 #       Supports POSIX termios speeds and old style speeds
  30 #       Searches termcaps properly (TERMPATH, etc)
  31 #       The output routines are optimized for cached Tputs().
  32 #       $this->{_xx} is the raw termcap data and $this->{xx} is a
  33 #           cached and padded string for count == 1.
  34 #
  35
  36 # internal routines
  37 sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
  38 sub termcap_path {
  39     local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
  40     local $v;
  41     if ($v = getenv(TERMPATH)) {
  42         # user specified path
  43         @termcap_path = split(':', $v);
  44     } else {
  45         # default path
  46         @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
  47         $v = getenv(HOME);
  48         unshift(@termcap_path, $v . '/.termcap') if $v;
  49     }
  50     # we always search TERMCAP first
  51     $v = getenv(TERMCAP);
  52     unshift(@termcap_path, $v) if $v =~ /^\//;
  53     grep(-f, @termcap_path);
  54 }
  55
  56 sub Tgetent {
  57     local($type) = shift;
  58     local($this) = @_;
  59     local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
  60
  61     warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
  62     $this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
  63     $term = $TERM = $this->{TERM} =
  64         $this->{TERM} || getenv(TERM) || die "Tgetent: TERM not set\n";
  65
  66     $TERMCAP = getenv(TERMCAP);
  67     $TERMCAP = '' if $TERMCAP =~ m:^/: || $TERMCAP !~ /(^|\|)$TERM[:\|]/;
  68     local @termcap_path = &termcap_path;
  69     die "Tgetent: Can't find a valid termcap file\n"
  70         unless @termcap_path || $TERMCAP;
  71
  72     # handle environment TERMCAP, setup for continuation if needed
  73     $entry = $TERMCAP;
  74     $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
  75     if ($TERMCAP eq '' || $1) {                         # the search goes on
  76         local $first = $TERMCAP eq '' ? 1 : 0;          # make it pretty
  77         local $max = 32;                                # max :tc=...:'s
  78         local $state = 1;                               # 0 == finished
  79                                                         # 1 == next file
  80                                                         # 2 == search again
  81         do {
  82             if ($state == 1) {
  83                 $TERMCAP = shift @termcap_path
  84                     || die "Tgetent: failed lookup on $TERM\n";
  85             } else {
  86                 $max-- || die "Tgetent: termcap loop at $TERM\n";
  87                 $state = 1;                             # back to default state
  88             }
  89
  90             open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
  91             # print STDERR "Trying... $TERMCAP\n";
  92             $loop = "
  93                 while (<TERMCAP>) {
  94                     next if /^\t/;
  95                     next if /^#/;
  96                     if (/(^|\\|)${TERM}[:\\|]/) {
  97                         chop;
  98                         s/^[^:]*:// unless \$first++;
  99                         \$state = 0;
 100                         while (chop eq '\\\\') {
 101                             \$_ .= <TERMCAP>;
 102                             chop;
 103                         }
 104                         \$_ .= ':';
 105                         last;
 106                     }
 107                 }
 108                 \$entry .= \$_;
 109             ";
 110             eval $loop;
 111             die $@ if $@;
 112             #print STDERR "$TERM: $_\n--------\n";      # DEBUG
 113             close TERMCAP;
 114             # If :tc=...: found then search this file again
 115             $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
 116         } while $state != 0;
 117     }
 118     die "Tgetent: Can't find $term\n" unless $entry ne '';
 119     $entry =~ s/:\s+:/:/g;
 120     $this->{TERMCAP} = $entry;
 121     #print STDERR $entry, "\n";                         # DEBUG
 122
 123     # Precompile $entry into the object
 124     foreach $field (split(/:[\s:\\]*/,$entry)) {
 125         if ($field =~ /^\w\w$/) {
 126             $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
 127         }
 128         elsif ($field =~ /^(\w\w)\@/) {
 129             $this->{'_' . $1} = "";
 130         }
 131         elsif ($field =~ /^(\w\w)#(.*)/) {
 132             $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
 133         }
 134         elsif ($field =~ /^(\w\w)=(.*)/) {
 135             next if defined $this->{'_' . ($cap = $1)};
 136             $_ = $2;
 137             s/\\E/\033/g;
 138             s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
 139             s/\\n/\n/g;
 140             s/\\r/\r/g;
 141             s/\\t/\t/g;
 142             s/\\b/\b/g;
 143             s/\\f/\f/g;
 144             s/\\\^/\377/g;
 145             s/\^\?/\177/g;
 146             s/\^(.)/pack('c',ord($1) & 31)/eg;
 147             s/\\(.)/$1/g;
 148             s/\377/^/g;
 149             $this->{'_' . $cap} = $_;
 150         }
 151         # else { warn "Tgetent: junk in $term: $field\n"; }
 152     }
 153     $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
 154     $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
 155     $this;
 156 }
 157
 158 # delays for old style speeds
 159 @Tpad = (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);
 160
 161 # $term->Tpad($string, $cnt, $FH);
 162 sub Tpad {
 163     local($this, $string, $cnt, $FH) = @_;
 164     local($decr, $ms);
 165
 166     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
 167         $ms = $1;
 168         $ms *= $cnt if $2;
 169         $string = $3;
 170         $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
 171         if ($decr > .1) {
 172             $ms += $decr / 2;
 173             $string .= $this->{'_pc'} x ($ms / $decr);
 174         }
 175     }
 176     print $FH $string if $FH;
 177     $string;
 178 }
 179
 180 # $term->Tputs($cap, $cnt, $FH);
 181 sub Tputs {
 182     local($this, $cap, $cnt, $FH) = @_;
 183     local $string;
 184
 185     if ($cnt > 1) {
 186         $string = Tpad($this, $this->{'_' . $cap}, $cnt);
 187     } else {
 188         $string = defined $this->{$cap} ? $this->{$cap} :
 189             ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
 190     }
 191     print $FH $string if $FH;
 192     $string;
 193 }
 194
 195 # %%   output `%'
 196 # %d   output value as in printf %d
 197 # %2   output value as in printf %2d
 198 # %3   output value as in printf %3d
 199 # %.   output value as in printf %c
 200 # %+x  add x to value, then do %.
 201 #
 202 # %>xy if value > x then add y, no output
 203 # %r   reverse order of two parameters, no output
 204 # %i   increment by one, no output
 205 # %B   BCD (16*(value/10)) + (value%10), no output
 206 #
 207 # %n   exclusive-or all parameters with 0140 (Datamedia 2500)
 208 # %D   Reverse coding (value - 2*(value%16)), no output (Delta Data)
 209 #
 210 # $term->Tgoto($cap, $col, $row, $FH);
 211 sub Tgoto {
 212     local($this, $cap, $code, $tmp, $FH) = @_;
 213     local $string = $this->{'_' . $cap};
 214     local $result = '';
 215     local $after = '';
 216     local $online = 0;
 217     local @tmp = ($tmp,$code);
 218     local $cnt = $code;
 219
 220     while ($string =~ /^([^%]*)%(.)(.*)/) {
 221         $result .= $1;
 222         $code = $2;
 223         $string = $3;
 224         if ($code eq 'd') {
 225             $result .= sprintf("%d",shift(@tmp));
 226         }
 227         elsif ($code eq '.') {
 228             $tmp = shift(@tmp);
 229             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
 230                 if ($online) {
 231                     ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
 232                 }
 233                 else {
 234                     ++$tmp, $after .= $this->{'_bc'};
 235                 }
 236             }
 237             $result .= sprintf("%c",$tmp);
 238             $online = !$online;
 239         }
 240         elsif ($code eq '+') {
 241             $result .= sprintf("%c",shift(@tmp)+ord($string));
 242             $string = substr($string,1,99);
 243             $online = !$online;
 244         }
 245         elsif ($code eq 'r') {
 246             ($code,$tmp) = @tmp;
 247             @tmp = ($tmp,$code);
 248             $online = !$online;
 249         }
 250         elsif ($code eq '>') {
 251             ($code,$tmp,$string) = unpack("CCa99",$string);
 252             if ($tmp[$[] > $code) {
 253                 $tmp[$[] += $tmp;
 254             }
 255         }
 256         elsif ($code eq '2') {
 257             $result .= sprintf("%02d",shift(@tmp));
 258             $online = !$online;
 259         }
 260         elsif ($code eq '3') {
 261             $result .= sprintf("%03d",shift(@tmp));
 262             $online = !$online;
 263         }
 264         elsif ($code eq 'i') {
 265             ($code,$tmp) = @tmp;
 266             @tmp = ($code+1,$tmp+1);
 267         }
 268         else {
 269             return "OOPS";
 270         }
 271     }
 272     $string = Tpad($this, $result . $string . $after, $cnt);
 273     print $FH $string if $FH;
 274     $string;
 275 }
 276
 277 # $this->Trequire($cap1, $cap2, ...);
 278 sub Trequire {
 279     local $this = shift;
 280     local $_;
 281     foreach (@_) {
 282         die "Trequire: Terminal does not support: $_\n"
 283             unless defined $this->{'_' . $_} && $this->{'_' . $_};
 284     }
 285 }
 286
 287 1;