lib/termcap.pl

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