[Summary view] [Print] [Text view]

   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;