home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 November / PCWorld_2004-11_cd.bin / software / topware / activeperl / ActivePerl-5.8.4.810-MSWin32-x86.exe / ActivePerl-5.8.4.810 / Perl / lib / termcap.pl < prev    next >
Text File  |  2004-06-01  |  4KB  |  179 lines
  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;
  179.