I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / termcap.pl
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;