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