lib/termcap.pl

   1 ;# $Header: termcap.pl,v 3.0.1.2 90/03/14 12:28:28 lwall Locked $
   2 ;#
   3 ;# Usage:
   4 ;#      do 'ioctl.pl';
   5 ;#      ioctl(TTY,$TIOCGETP,$foo);
   6 ;#      ($ispeed,$ospeed) = unpack('cc',$foo);
   7 ;#      do 'termcap.pl' || die "Can't get termcap.pl";
   8 ;#      &Tgetent('vt100');      # sets $TC{'cm'}, etc.
   9 ;#      &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
  10 ;#      &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
  11 ;#
  12 sub Tgetent {
  13     local($TERM) = @_;
  14     local($TERMCAP,$_,$entry,$loop,$field);
  15
  16     warn "Tgetent: no ospeed set" unless $ospeed;
  17     foreach $key (keys(TC)) {
  18         delete $TC{$key};
  19     }
  20     $TERM = $ENV{'TERM'} unless $TERM;
  21     $TERMCAP = $ENV{'TERMCAP'};
  22     $TERMCAP = '/etc/termcap' unless $TERMCAP;
  23     if ($TERMCAP !~ m:^/:) {
  24         if (index($TERMCAP,"|$TERM|") < $[) {
  25             $TERMCAP = '/etc/termcap';
  26         }
  27     }
  28     if ($TERMCAP =~ m:^/:) {
  29         $entry = '';
  30         do {
  31             $loop = "
  32             open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
  33             while (<TERMCAP>) {
  34                 next if /^#/;
  35                 next if /^\t/;
  36                 if (/\\|$TERM[:\\|]/) {
  37                     chop;
  38                     while (chop eq '\\\\') {
  39                         \$_ .= <TERMCAP>;
  40                         chop;
  41                     }
  42                     \$_ .= ':';
  43                     last;
  44                 }
  45             }
  46             close TERMCAP;
  47             \$entry .= \$_;
  48             ";
  49             eval $loop;
  50         } while s/:tc=([^:]+):/:/ && ($TERM = $1);
  51         $TERMCAP = $entry;
  52     }
  53
  54     foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
  55         if ($field =~ /^\w\w$/) {
  56             $TC{$field} = 1;
  57         }
  58         elsif ($field =~ /^(\w\w)#(.*)/) {
  59             $TC{$1} = $2 if $TC{$1} eq '';
  60         }
  61         elsif ($field =~ /^(\w\w)=(.*)/) {
  62             $entry = $1;
  63             $_ = $2;
  64             s/\\E/\033/g;
  65             s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  66             s/\\n/\n/g;
  67             s/\\r/\r/g;
  68             s/\\t/\t/g;
  69             s/\\b/\b/g;
  70             s/\\f/\f/g;
  71             s/\\\^/\377/g;
  72             s/\^\?/\177/g;
  73             s/\^(.)/pack('c',ord($1) & 31)/eg;
  74             s/\\(.)/$1/g;
  75             s/\377/^/g;
  76             $TC{$entry} = $_ if $TC{$entry} eq '';
  77         }
  78     }
  79     $TC{'pc'} = "\0" if $TC{'pc'} eq '';
  80     $TC{'bc'} = "\b" if $TC{'bc'} eq '';
  81 }
  82
  83 @Tputs = (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);
  84
  85 sub Tputs {
  86     local($string,$affcnt,$FH) = @_;
  87     local($ms);
  88     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  89         $ms = $1;
  90         $ms *= $affcnt if $2;
  91         $string = $3;
  92         $decr = $Tputs[$ospeed];
  93         if ($decr > .1) {
  94             $ms += $decr / 2;
  95             $string .= $TC{'pc'} x ($ms / $decr);
  96         }
  97     }
  98     print $FH $string if $FH;
  99     $string;
 100 }
 101
 102 sub Tgoto {
 103     local($string) = shift(@_);
 104     local($result) = '';
 105     local($after) = '';
 106     local($code,$tmp) = @_;
 107     local(@tmp);
 108     @tmp = ($tmp,$code);
 109     local($online) = 0;
 110     while ($string =~ /^([^%]*)%(.)(.*)/) {
 111         $result .= $1;
 112         $code = $2;
 113         $string = $3;
 114         if ($code eq 'd') {
 115             $result .= sprintf("%d",shift(@tmp));
 116         }
 117         elsif ($code eq '.') {
 118             $tmp = shift(@tmp);
 119             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
 120                 if ($online) {
 121                     ++$tmp, $after .= $TC{'up'} if $TC{'up'};
 122                 }
 123                 else {
 124                     ++$tmp, $after .= $TC{'bc'};
 125                 }
 126             }
 127             $result .= sprintf("%c",$tmp);
 128             $online = !$online;
 129         }
 130         elsif ($code eq '+') {
 131             $result .= sprintf("%c",shift(@tmp)+ord($string));
 132             $string = substr($string,1,99);
 133             $online = !$online;
 134         }
 135         elsif ($code eq 'r') {
 136             ($code,$tmp) = @tmp;
 137             @tmp = ($tmp,$code);
 138             $online = !$online;
 139         }
 140         elsif ($code eq '>') {
 141             ($code,$tmp,$string) = unpack("CCa99",$string);
 142             if ($tmp[$[] > $code) {
 143                 $tmp[$[] += $tmp;
 144             }
 145         }
 146         elsif ($code eq '2') {
 147             $result .= sprintf("%02d",shift(@tmp));
 148             $online = !$online;
 149         }
 150         elsif ($code eq '3') {
 151             $result .= sprintf("%03d",shift(@tmp));
 152             $online = !$online;
 153         }
 154         elsif ($code eq 'i') {
 155             ($code,$tmp) = @tmp;
 156             @tmp = ($code+1,$tmp+1);
 157         }
 158         else {
 159             return "OOPS";
 160         }
 161     }
 162     $result . $string . $after;
 163 }
 164
 165 1;