home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / Term / Cap.pm next >
Text File  |  1995-03-16  |  8KB  |  288 lines
  1. # Term::Cap.pm -- Termcap interface routines
  2. package Term::Cap;
  3.  
  4. # Converted to package on 25 Feb 1994 <sanders@bsdi.com>
  5. #
  6. # Usage:
  7. #    require 'ioctl.pl';
  8. #    ioctl(TTY,$TIOCGETP,$sgtty);
  9. #    ($ispeed,$ospeed) = unpack('cc',$sgtty);
  10. #
  11. #    require Term::Cap;
  12. #
  13. #    $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
  14. #        sets $term->{'_cm'}, etc.
  15. #    $this->Trequire(qw/ce ku kd/);
  16. #        die unless entries are defined for the terminal
  17. #    $term->Tgoto('cm', $col, $row, $FH);
  18. #    $term->Tputs('dl', $cnt = 1, $FH);
  19. #    $this->Tpad($string, $cnt = 1, $FH);
  20. #        processes a termcap string and adds padding if needed
  21. #        if $FH is undefined these just return the string
  22. #
  23. # CHANGES:
  24. #    Converted to package
  25. #    Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
  26. #    Now die's properly if it can't open $TERMCAP or if the eval $loop fails
  27. #    Tputs() results are cached (use Tgoto or Tpad to avoid)
  28. #    Tgoto() will do output if $FH is passed (like Tputs without caching)
  29. #    Supports POSIX termios speeds and old style speeds
  30. #    Searches termcaps properly (TERMPATH, etc)
  31. #    The output routines are optimized for cached Tputs().
  32. #    $this->{_xx} is the raw termcap data and $this->{xx} is a
  33. #        cached and padded string for count == 1.
  34. #
  35.  
  36. # internal routines
  37. sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
  38. sub termcap_path {
  39.     local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
  40.     local $v;
  41.     if ($v = getenv(TERMPATH)) {
  42.     # user specified path
  43.     @termcap_path = split(':', $v);
  44.     } else {
  45.     # default path
  46.     @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
  47.     $v = getenv(HOME);
  48.     unshift(@termcap_path, $v . '/.termcap') if $v;
  49.     }
  50.     # we always search TERMCAP first
  51.     $v = getenv(TERMCAP);
  52.     unshift(@termcap_path, $v) if $v =~ /^\//;
  53.     grep(-f, @termcap_path);
  54. }
  55.  
  56. sub Tgetent {
  57.     local($type) = shift;
  58.     local($this) = @_;
  59.     local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
  60.  
  61.     warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
  62.     $this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
  63.     $term = $TERM = $this->{TERM} =
  64.     $this->{TERM} || getenv(TERM) || die "Tgetent: TERM not set\n";
  65.  
  66.     $TERMCAP = getenv(TERMCAP);
  67.     $TERMCAP = '' if $TERMCAP =~ m:^/: || $TERMCAP !~ /(^|\|)$TERM[:\|]/;
  68.     local @termcap_path = &termcap_path;
  69.     die "Tgetent: Can't find a valid termcap file\n"
  70.     unless @termcap_path || $TERMCAP;
  71.  
  72.     # handle environment TERMCAP, setup for continuation if needed
  73.     $entry = $TERMCAP;
  74.     $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
  75.     if ($TERMCAP eq '' || $1) {                # the search goes on
  76.     local $first = $TERMCAP eq '' ? 1 : 0;        # make it pretty
  77.     local $max = 32;                # max :tc=...:'s
  78.     local $state = 1;                # 0 == finished
  79.                             # 1 == next file
  80.                             # 2 == search again
  81.     do {
  82.         if ($state == 1) {
  83.         $TERMCAP = shift @termcap_path
  84.             || die "Tgetent: failed lookup on $TERM\n";
  85.         } else {
  86.         $max-- || die "Tgetent: termcap loop at $TERM\n";
  87.         $state = 1;                # back to default state
  88.         }
  89.  
  90.         open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
  91.         # print STDERR "Trying... $TERMCAP\n";
  92.         $loop = "
  93.         while (<TERMCAP>) {
  94.             next if /^\t/;
  95.             next if /^#/;
  96.             if (/(^|\\|)${TERM}[:\\|]/) {
  97.             chop;
  98.             s/^[^:]*:// unless \$first++;
  99.             \$state = 0;
  100.             while (chop eq '\\\\') {
  101.                 \$_ .= <TERMCAP>;
  102.                 chop;
  103.             }
  104.             \$_ .= ':';
  105.             last;
  106.             }
  107.         }
  108.         \$entry .= \$_;
  109.         ";
  110.         eval $loop;
  111.         die $@ if $@;
  112.         #print STDERR "$TERM: $_\n--------\n";    # DEBUG
  113.         close TERMCAP;
  114.         # If :tc=...: found then search this file again
  115.         $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
  116.     } while $state != 0;
  117.     }
  118.     die "Tgetent: Can't find $term\n" unless $entry ne '';
  119.     $entry =~ s/:\s+:/:/g;
  120.     $this->{TERMCAP} = $entry;
  121.     #print STDERR $entry, "\n";                # DEBUG
  122.  
  123.     # Precompile $entry into the object
  124.     foreach $field (split(/:[\s:\\]*/,$entry)) {
  125.     if ($field =~ /^\w\w$/) {
  126.         $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
  127.     }
  128.     elsif ($field =~ /^(\w\w)\@/) {
  129.         $this->{'_' . $1} = "";
  130.     }
  131.     elsif ($field =~ /^(\w\w)#(.*)/) {
  132.         $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
  133.     }
  134.     elsif ($field =~ /^(\w\w)=(.*)/) {
  135.         next if defined $this->{'_' . ($cap = $1)};
  136.         $_ = $2;
  137.         s/\\E/\033/g;
  138.         s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
  139.         s/\\n/\n/g;
  140.         s/\\r/\r/g;
  141.         s/\\t/\t/g;
  142.         s/\\b/\b/g;
  143.         s/\\f/\f/g;
  144.         s/\\\^/\377/g;
  145.         s/\^\?/\177/g;
  146.         s/\^(.)/pack('c',ord($1) & 31)/eg;
  147.         s/\\(.)/$1/g;
  148.         s/\377/^/g;
  149.         $this->{'_' . $cap} = $_;
  150.     }
  151.     # else { warn "Tgetent: junk in $term: $field\n"; }
  152.     }
  153.     $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
  154.     $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
  155.     $this;
  156. }
  157.  
  158. # delays for old style speeds
  159. @Tpad = (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);
  160.  
  161. # $term->Tpad($string, $cnt, $FH);
  162. sub Tpad {
  163.     local($this, $string, $cnt, $FH) = @_;
  164.     local($decr, $ms);
  165.  
  166.     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  167.     $ms = $1;
  168.     $ms *= $cnt if $2;
  169.     $string = $3;
  170.     $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
  171.     if ($decr > .1) {
  172.         $ms += $decr / 2;
  173.         $string .= $this->{'_pc'} x ($ms / $decr);
  174.     }
  175.     }
  176.     print $FH $string if $FH;
  177.     $string;
  178. }
  179.  
  180. # $term->Tputs($cap, $cnt, $FH);
  181. sub Tputs {
  182.     local($this, $cap, $cnt, $FH) = @_;
  183.     local $string;
  184.  
  185.     if ($cnt > 1) {
  186.     $string = Tpad($this, $this->{'_' . $cap}, $cnt);
  187.     } else {
  188.     $string = defined $this->{$cap} ? $this->{$cap} :
  189.         ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
  190.     }
  191.     print $FH $string if $FH;
  192.     $string;
  193. }
  194.  
  195. # %%   output `%'
  196. # %d   output value as in printf %d
  197. # %2   output value as in printf %2d
  198. # %3   output value as in printf %3d
  199. # %.   output value as in printf %c
  200. # %+x  add x to value, then do %.
  201. #
  202. # %>xy if value > x then add y, no output
  203. # %r   reverse order of two parameters, no output
  204. # %i   increment by one, no output
  205. # %B   BCD (16*(value/10)) + (value%10), no output
  206. #
  207. # %n   exclusive-or all parameters with 0140 (Datamedia 2500)
  208. # %D   Reverse coding (value - 2*(value%16)), no output (Delta Data)
  209. #
  210. # $term->Tgoto($cap, $col, $row, $FH);
  211. sub Tgoto {
  212.     local($this, $cap, $code, $tmp, $FH) = @_;
  213.     local $string = $this->{'_' . $cap};
  214.     local $result = '';
  215.     local $after = '';
  216.     local $online = 0;
  217.     local @tmp = ($tmp,$code);
  218.     local $cnt = $code;
  219.  
  220.     while ($string =~ /^([^%]*)%(.)(.*)/) {
  221.     $result .= $1;
  222.     $code = $2;
  223.     $string = $3;
  224.     if ($code eq 'd') {
  225.         $result .= sprintf("%d",shift(@tmp));
  226.     }
  227.     elsif ($code eq '.') {
  228.         $tmp = shift(@tmp);
  229.         if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
  230.         if ($online) {
  231.             ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
  232.         }
  233.         else {
  234.             ++$tmp, $after .= $this->{'_bc'};
  235.         }
  236.         }
  237.         $result .= sprintf("%c",$tmp);
  238.         $online = !$online;
  239.     }
  240.     elsif ($code eq '+') {
  241.         $result .= sprintf("%c",shift(@tmp)+ord($string));
  242.         $string = substr($string,1,99);
  243.         $online = !$online;
  244.     }
  245.     elsif ($code eq 'r') {
  246.         ($code,$tmp) = @tmp;
  247.         @tmp = ($tmp,$code);
  248.         $online = !$online;
  249.     }
  250.     elsif ($code eq '>') {
  251.         ($code,$tmp,$string) = unpack("CCa99",$string);
  252.         if ($tmp[$[] > $code) {
  253.         $tmp[$[] += $tmp;
  254.         }
  255.     }
  256.     elsif ($code eq '2') {
  257.         $result .= sprintf("%02d",shift(@tmp));
  258.         $online = !$online;
  259.     }
  260.     elsif ($code eq '3') {
  261.         $result .= sprintf("%03d",shift(@tmp));
  262.         $online = !$online;
  263.     }
  264.     elsif ($code eq 'i') {
  265.         ($code,$tmp) = @tmp;
  266.         @tmp = ($code+1,$tmp+1);
  267.     }
  268.     else {
  269.         return "OOPS";
  270.     }
  271.     }
  272.     $string = Tpad($this, $result . $string . $after, $cnt);
  273.     print $FH $string if $FH;
  274.     $string;
  275. }
  276.  
  277. # $this->Trequire($cap1, $cap2, ...);
  278. sub Trequire {
  279.     local $this = shift;
  280.     local $_;
  281.     foreach (@_) {
  282.     die "Trequire: Terminal does not support: $_\n"
  283.         unless defined $this->{'_' . $_} && $this->{'_' . $_};
  284.     }
  285. }
  286.  
  287. 1;
  288.