lib/termcap.pl

   1 ;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
   2 #
   3 # This library is no longer being maintained, and is included for backward
   4 # compatibility with Perl 4 programs which may require it.
   5 # This legacy library is deprecated and will be removed in a future
   6 # release of perl.
   7 #
   8 # In particular, this should not be used as an example of modern Perl
   9 # programming techniques.
  10 #
  11 # Suggested alternative: Term::Cap
  12 #
  13
  14 ;#
  15 ;# Usage:
  16 ;#      require 'ioctl.pl';
  17 ;#      ioctl(TTY,$TIOCGETP,$foo);
  18 ;#      ($ispeed,$ospeed) = unpack('cc',$foo);
  19 ;#      require 'termcap.pl';
  20 ;#      &Tgetent('vt100');      # sets $TC{'cm'}, etc.
  21 ;#      &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
  22 ;#      &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
  23 ;#
  24 sub Tgetent {
  25     local($TERM) = @_;
  26     local($TERMCAP,$_,$entry,$loop,$field);
  27
  28     # warn "Tgetent: no ospeed set" unless $ospeed;
  29     foreach $key (keys %TC) {
  30         delete $TC{$key};
  31     }
  32     $TERM = $ENV{'TERM'} unless $TERM;
  33     $TERM =~ s/(\W)/\\$1/g;
  34     $TERMCAP = $ENV{'TERMCAP'};
  35     $TERMCAP = '/etc/termcap' unless $TERMCAP;
  36     if ($TERMCAP !~ m:^/:) {
  37         if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
  38             $TERMCAP = '/etc/termcap';
  39         }
  40     }
  41     if ($TERMCAP =~ m:^/:) {
  42         $entry = '';
  43         do {
  44             $loop = "
  45             open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
  46             while (<TERMCAP>) {
  47                 next if /^#/;
  48                 next if /^\t/;
  49                 if (/(^|\\|)${TERM}[:\\|]/) {
  50                     chop;
  51                     while (chop eq '\\\\') {
  52                         \$_ .= <TERMCAP>;
  53                         chop;
  54                     }
  55                     \$_ .= ':';
  56                     last;
  57                 }
  58             }
  59             close TERMCAP;
  60             \$entry .= \$_;
  61             ";
  62             eval $loop;
  63         } while s/:tc=([^:]+):/:/ && ($TERM = $1);
  64         $TERMCAP = $entry;
  65     }
  66
  67     foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
  68         if ($field =~ /^\w\w$/) {
  69             $TC{$field} = 1;
  70         }
  71         elsif ($field =~ /^(\w\w)#(.*)/) {
  72             $TC{$1} = $2 if $TC{$1} eq '';
  73         }
  74         elsif ($field =~ /^(\w\w)=(.*)/) {
  75             $entry = $1;
  76             $_ = $2;
  77             s/\\E/\033/g;
  78             s/\\(200)/pack('c',0)/eg;                   # NUL character
  79             s/\\(0\d\d)/pack('c',oct($1))/eg;   # octal
  80             s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg;        # hex
  81             s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  82             s/\\n/\n/g;
  83             s/\\r/\r/g;
  84             s/\\t/\t/g;
  85             s/\\b/\b/g;
  86             s/\\f/\f/g;
  87             s/\\\^/\377/g;
  88             s/\^\?/\177/g;
  89             s/\^(.)/pack('c',ord($1) & 31)/eg;
  90             s/\\(.)/$1/g;
  91             s/\377/^/g;
  92             $TC{$entry} = $_ if $TC{$entry} eq '';
  93         }
  94     }
  95     $TC{'pc'} = "\0" if $TC{'pc'} eq '';
  96     $TC{'bc'} = "\b" if $TC{'bc'} eq '';
  97 }
  98
  99 @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);
 100
 101 sub Tputs {
 102     local($string,$affcnt,$FH) = @_;
 103     local($ms);
 104     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
 105         $ms = $1;
 106         $ms *= $affcnt if $2;
 107         $string = $3;
 108         $decr = $Tputs[$ospeed];
 109         if ($decr > .1) {
 110             $ms += $decr / 2;
 111             $string .= $TC{'pc'} x ($ms / $decr);
 112         }
 113     }
 114     print $FH $string if $FH;
 115     $string;
 116 }
 117
 118 sub Tgoto {
 119     local($string) = shift(@_);
 120     local($result) = '';
 121     local($after) = '';
 122     local($code,$tmp) = @_;
 123     local(@tmp);
 124     @tmp = ($tmp,$code);
 125     local($online) = 0;
 126     while ($string =~ /^([^%]*)%(.)(.*)/) {
 127         $result .= $1;
 128         $code = $2;
 129         $string = $3;
 130         if ($code eq 'd') {
 131             $result .= sprintf("%d",shift(@tmp));
 132         }
 133         elsif ($code eq '.') {
 134             $tmp = shift(@tmp);
 135             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
 136                 if ($online) {
 137                     ++$tmp, $after .= $TC{'up'} if $TC{'up'};
 138                 }
 139                 else {
 140                     ++$tmp, $after .= $TC{'bc'};
 141                 }
 142             }
 143             $result .= sprintf("%c",$tmp);
 144             $online = !$online;
 145         }
 146         elsif ($code eq '+') {
 147             $result .= sprintf("%c",shift(@tmp)+ord($string));
 148             $string = substr($string,1,99);
 149             $online = !$online;
 150         }
 151         elsif ($code eq 'r') {
 152             ($code,$tmp) = @tmp;
 153             @tmp = ($tmp,$code);
 154             $online = !$online;
 155         }
 156         elsif ($code eq '>') {
 157             ($code,$tmp,$string) = unpack("CCa99",$string);
 158             if ($tmp[0] > $code) {
 159                 $tmp[0] += $tmp;
 160             }
 161         }
 162         elsif ($code eq '2') {
 163             $result .= sprintf("%02d",shift(@tmp));
 164             $online = !$online;
 165         }
 166         elsif ($code eq '3') {
 167             $result .= sprintf("%03d",shift(@tmp));
 168             $online = !$online;
 169         }
 170         elsif ($code eq 'i') {
 171             ($code,$tmp) = @tmp;
 172             @tmp = ($code+1,$tmp+1);
 173         }
 174         else {
 175             return "OOPS";
 176         }
 177     }
 178     $result . $string . $after;
 179 }
 180
 181 1;