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