lib/Term/Cap.pm

   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;