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