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