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