perl 4.0 patch 32: patch #20, continued
[perl.git] / lib / termcap.pl
1 ;# $RCSfile: termcap.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:49:17 $
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     $TERMCAP = $ENV{'TERMCAP'};
22     $TERMCAP = '/etc/termcap' unless $TERMCAP;
23     if ($TERMCAP !~ m:^/:) {
24         if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
25             $TERMCAP = '/etc/termcap';
26         }
27     }
28     if ($TERMCAP =~ m:^/:) {
29         $entry = '';
30         do {
31             $loop = "
32             open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
33             while (<TERMCAP>) {
34                 next if /^#/;
35                 next if /^\t/;
36                 if (/(^|\\|)$TERM[:\\|]/) {
37                     chop;
38                     while (chop eq '\\\\') {
39                         \$_ .= <TERMCAP>;
40                         chop;
41                     }
42                     \$_ .= ':';
43                     last;
44                 }
45             }
46             close TERMCAP;
47             \$entry .= \$_;
48             ";
49             eval $loop;
50         } while s/:tc=([^:]+):/:/ && ($TERM = $1);
51         $TERMCAP = $entry;
52     }
53
54     foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
55         if ($field =~ /^\w\w$/) {
56             $TC{$field} = 1;
57         }
58         elsif ($field =~ /^(\w\w)#(.*)/) {
59             $TC{$1} = $2 if $TC{$1} eq '';
60         }
61         elsif ($field =~ /^(\w\w)=(.*)/) {
62             $entry = $1;
63             $_ = $2;
64             s/\\E/\033/g;
65             s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
66             s/\\n/\n/g;
67             s/\\r/\r/g;
68             s/\\t/\t/g;
69             s/\\b/\b/g;
70             s/\\f/\f/g;
71             s/\\\^/\377/g;
72             s/\^\?/\177/g;
73             s/\^(.)/pack('c',ord($1) & 31)/eg;
74             s/\\(.)/$1/g;
75             s/\377/^/g;
76             $TC{$entry} = $_ if $TC{$entry} eq '';
77         }
78     }
79     $TC{'pc'} = "\0" if $TC{'pc'} eq '';
80     $TC{'bc'} = "\b" if $TC{'bc'} eq '';
81 }
82
83 @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);
84
85 sub Tputs {
86     local($string,$affcnt,$FH) = @_;
87     local($ms);
88     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
89         $ms = $1;
90         $ms *= $affcnt if $2;
91         $string = $3;
92         $decr = $Tputs[$ospeed];
93         if ($decr > .1) {
94             $ms += $decr / 2;
95             $string .= $TC{'pc'} x ($ms / $decr);
96         }
97     }
98     print $FH $string if $FH;
99     $string;
100 }
101
102 sub Tgoto {
103     local($string) = shift(@_);
104     local($result) = '';
105     local($after) = '';
106     local($code,$tmp) = @_;
107     local(@tmp);
108     @tmp = ($tmp,$code);
109     local($online) = 0;
110     while ($string =~ /^([^%]*)%(.)(.*)/) {
111         $result .= $1;
112         $code = $2;
113         $string = $3;
114         if ($code eq 'd') {
115             $result .= sprintf("%d",shift(@tmp));
116         }
117         elsif ($code eq '.') {
118             $tmp = shift(@tmp);
119             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
120                 if ($online) {
121                     ++$tmp, $after .= $TC{'up'} if $TC{'up'};
122                 }
123                 else {
124                     ++$tmp, $after .= $TC{'bc'};
125                 }
126             }
127             $result .= sprintf("%c",$tmp);
128             $online = !$online;
129         }
130         elsif ($code eq '+') {
131             $result .= sprintf("%c",shift(@tmp)+ord($string));
132             $string = substr($string,1,99);
133             $online = !$online;
134         }
135         elsif ($code eq 'r') {
136             ($code,$tmp) = @tmp;
137             @tmp = ($tmp,$code);
138             $online = !$online;
139         }
140         elsif ($code eq '>') {
141             ($code,$tmp,$string) = unpack("CCa99",$string);
142             if ($tmp[$[] > $code) {
143                 $tmp[$[] += $tmp;
144             }
145         }
146         elsif ($code eq '2') {
147             $result .= sprintf("%02d",shift(@tmp));
148             $online = !$online;
149         }
150         elsif ($code eq '3') {
151             $result .= sprintf("%03d",shift(@tmp));
152             $online = !$online;
153         }
154         elsif ($code eq 'i') {
155             ($code,$tmp) = @tmp;
156             @tmp = ($code+1,$tmp+1);
157         }
158         else {
159             return "OOPS";
160         }
161     }
162     $result . $string . $after;
163 }
164
165 1;