lib/termcap.pl

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