contrib/perl5/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/\\(200)/pack('c',0)/eg;                   # NUL character
  67             s/\\(0\d\d)/pack('c',oct($1))/eg;   # octal
  68             s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg;        # hex
  69             s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  70             s/\\n/\n/g;
  71             s/\\r/\r/g;
  72             s/\\t/\t/g;
  73             s/\\b/\b/g;
  74             s/\\f/\f/g;
  75             s/\\\^/\377/g;
  76             s/\^\?/\177/g;
  77             s/\^(.)/pack('c',ord($1) & 31)/eg;
  78             s/\\(.)/$1/g;
  79             s/\377/^/g;
  80             $TC{$entry} = $_ if $TC{$entry} eq '';
  81         }
  82     }
  83     $TC{'pc'} = "\0" if $TC{'pc'} eq '';
  84     $TC{'bc'} = "\b" if $TC{'bc'} eq '';
  85 }
  86
  87 @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);
  88
  89 sub Tputs {
  90     local($string,$affcnt,$FH) = @_;
  91     local($ms);
  92     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  93         $ms = $1;
  94         $ms *= $affcnt if $2;
  95         $string = $3;
  96         $decr = $Tputs[$ospeed];
  97         if ($decr > .1) {
  98             $ms += $decr / 2;
  99             $string .= $TC{'pc'} x ($ms / $decr);
 100         }
 101     }
 102     print $FH $string if $FH;
 103     $string;
 104 }
 105
 106 sub Tgoto {
 107     local($string) = shift(@_);
 108     local($result) = '';
 109     local($after) = '';
 110     local($code,$tmp) = @_;
 111     local(@tmp);
 112     @tmp = ($tmp,$code);
 113     local($online) = 0;
 114     while ($string =~ /^([^%]*)%(.)(.*)/) {
 115         $result .= $1;
 116         $code = $2;
 117         $string = $3;
 118         if ($code eq 'd') {
 119             $result .= sprintf("%d",shift(@tmp));
 120         }
 121         elsif ($code eq '.') {
 122             $tmp = shift(@tmp);
 123             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
 124                 if ($online) {
 125                     ++$tmp, $after .= $TC{'up'} if $TC{'up'};
 126                 }
 127                 else {
 128                     ++$tmp, $after .= $TC{'bc'};
 129                 }
 130             }
 131             $result .= sprintf("%c",$tmp);
 132             $online = !$online;
 133         }
 134         elsif ($code eq '+') {
 135             $result .= sprintf("%c",shift(@tmp)+ord($string));
 136             $string = substr($string,1,99);
 137             $online = !$online;
 138         }
 139         elsif ($code eq 'r') {
 140             ($code,$tmp) = @tmp;
 141             @tmp = ($tmp,$code);
 142             $online = !$online;
 143         }
 144         elsif ($code eq '>') {
 145             ($code,$tmp,$string) = unpack("CCa99",$string);
 146             if ($tmp[$[] > $code) {
 147                 $tmp[$[] += $tmp;
 148             }
 149         }
 150         elsif ($code eq '2') {
 151             $result .= sprintf("%02d",shift(@tmp));
 152             $online = !$online;
 153         }
 154         elsif ($code eq '3') {
 155             $result .= sprintf("%03d",shift(@tmp));
 156             $online = !$online;
 157         }
 158         elsif ($code eq 'i') {
 159             ($code,$tmp) = @tmp;
 160             @tmp = ($code+1,$tmp+1);
 161         }
 162         else {
 163             return "OOPS";
 164         }
 165     }
 166     $result . $string . $after;
 167 }
 168
 169 1;