home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / termcap.pl < prev    next >
Text File  |  1997-05-19  |  4KB  |  170 lines
  1. ;# $RCSfile: termcap.pl,v $$Revision: 1.3 $$Date: 1997/05/19 12:32:07 $
  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/\\(200)/pack('c',0)/eg;            # NUL character
  67.         s/\\(0\d\d)/pack('c',oct($1))/eg;    # octal
  68.         s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg;    # hex
  69.         s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  70.         s/\\n/\n/g;
  71.         s/\\r/\r/g;
  72.         s/\\t/\t/g;
  73.         s/\\b/\b/g;
  74.         s/\\f/\f/g;
  75.         s/\\\^/\377/g;
  76.         s/\^\?/\177/g;
  77.         s/\^(.)/pack('c',ord($1) & 31)/eg;
  78.         s/\\(.)/$1/g;
  79.         s/\377/^/g;
  80.         $TC{$entry} = $_ if $TC{$entry} eq '';
  81.     }
  82.     }
  83.     $TC{'pc'} = "\0" if $TC{'pc'} eq '';
  84.     $TC{'bc'} = "\b" if $TC{'bc'} eq '';
  85. }
  86.  
  87. @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);
  88.  
  89. sub Tputs {
  90.     local($string,$affcnt,$FH) = @_;
  91.     local($ms);
  92.     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  93.     $ms = $1;
  94.     $ms *= $affcnt if $2;
  95.     $string = $3;
  96.     $decr = $Tputs[$ospeed];
  97.     if ($decr > .1) {
  98.         $ms += $decr / 2;
  99.         $string .= $TC{'pc'} x ($ms / $decr);
  100.     }
  101.     }
  102.     print $FH $string if $FH;
  103.     $string;
  104. }
  105.  
  106. sub Tgoto {
  107.     local($string) = shift(@_);
  108.     local($result) = '';
  109.     local($after) = '';
  110.     local($code,$tmp) = @_;
  111.     local(@tmp);
  112.     @tmp = ($tmp,$code);
  113.     local($online) = 0;
  114.     while ($string =~ /^([^%]*)%(.)(.*)/) {
  115.     $result .= $1;
  116.     $code = $2;
  117.     $string = $3;
  118.     if ($code eq 'd') {
  119.         $result .= sprintf("%d",shift(@tmp));
  120.     }
  121.     elsif ($code eq '.') {
  122.         $tmp = shift(@tmp);
  123.         if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
  124.         if ($online) {
  125.             ++$tmp, $after .= $TC{'up'} if $TC{'up'};
  126.         }
  127.         else {
  128.             ++$tmp, $after .= $TC{'bc'};
  129.         }
  130.         }
  131.         $result .= sprintf("%c",$tmp);
  132.         $online = !$online;
  133.     }
  134.     elsif ($code eq '+') {
  135.         $result .= sprintf("%c",shift(@tmp)+ord($string));
  136.         $string = substr($string,1,99);
  137.         $online = !$online;
  138.     }
  139.     elsif ($code eq 'r') {
  140.         ($code,$tmp) = @tmp;
  141.         @tmp = ($tmp,$code);
  142.         $online = !$online;
  143.     }
  144.     elsif ($code eq '>') {
  145.         ($code,$tmp,$string) = unpack("CCa99",$string);
  146.         if ($tmp[$[] > $code) {
  147.         $tmp[$[] += $tmp;
  148.         }
  149.     }
  150.     elsif ($code eq '2') {
  151.         $result .= sprintf("%02d",shift(@tmp));
  152.         $online = !$online;
  153.     }
  154.     elsif ($code eq '3') {
  155.         $result .= sprintf("%03d",shift(@tmp));
  156.         $online = !$online;
  157.     }
  158.     elsif ($code eq 'i') {
  159.         ($code,$tmp) = @tmp;
  160.         @tmp = ($code+1,$tmp+1);
  161.     }
  162.     else {
  163.         return "OOPS";
  164.     }
  165.     }
  166.     $result . $string . $after;
  167. }
  168.  
  169. 1;
  170.