Commit | Line | Data |
748a9306 |
1 | # Term::Cap.pm -- Termcap interface routines |
a0d0e21e |
2 | package Term::Cap; |
85e6fe83 |
3 | |
748a9306 |
4 | # Converted to package on 25 Feb 1994 <sanders@bsdi.com> |
a0d0e21e |
5 | # |
6 | # Usage: |
7 | # require 'ioctl.pl'; |
748a9306 |
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. |
a0d0e21e |
34 | # |
a687059c |
35 | |
748a9306 |
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; |
a687059c |
49 | } |
748a9306 |
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 |
a687059c |
81 | do { |
748a9306 |
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"; |
a687059c |
92 | $loop = " |
748a9306 |
93 | while (<TERMCAP>) { |
94 | next if /^\t/; |
95 | next if /^#/; |
96 | if (/(^|\\|)${TERM}[:\\|]/) { |
a687059c |
97 | chop; |
748a9306 |
98 | s/^[^:]*:// unless \$first++; |
99 | \$state = 0; |
100 | while (chop eq '\\\\') { |
101 | \$_ .= <TERMCAP>; |
102 | chop; |
103 | } |
104 | \$_ .= ':'; |
105 | last; |
a687059c |
106 | } |
a687059c |
107 | } |
748a9306 |
108 | \$entry .= \$_; |
a687059c |
109 | "; |
110 | eval $loop; |
748a9306 |
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; |
a687059c |
117 | } |
748a9306 |
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 |
a687059c |
122 | |
748a9306 |
123 | # Precompile $entry into the object |
124 | foreach $field (split(/:[\s:\\]*/,$entry)) { |
a687059c |
125 | if ($field =~ /^\w\w$/) { |
748a9306 |
126 | $this->{'_' . $field} = 1 unless defined $this->{'_' . $1}; |
127 | } |
128 | elsif ($field =~ /^(\w\w)\@/) { |
129 | $this->{'_' . $1} = ""; |
a687059c |
130 | } |
131 | elsif ($field =~ /^(\w\w)#(.*)/) { |
748a9306 |
132 | $this->{'_' . $1} = $2 unless defined $this->{'_' . $1}; |
a687059c |
133 | } |
134 | elsif ($field =~ /^(\w\w)=(.*)/) { |
748a9306 |
135 | next if defined $this->{'_' . ($cap = $1)}; |
a687059c |
136 | $_ = $2; |
137 | s/\\E/\033/g; |
ecfc5424 |
138 | s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; |
a687059c |
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; |
63f2c1e1 |
146 | s/\^(.)/pack('c',ord($1) & 31)/eg; |
a687059c |
147 | s/\\(.)/$1/g; |
148 | s/\377/^/g; |
748a9306 |
149 | $this->{'_' . $cap} = $_; |
a687059c |
150 | } |
748a9306 |
151 | # else { warn "Tgetent: junk in $term: $field\n"; } |
a687059c |
152 | } |
748a9306 |
153 | $this->{'_pc'} = "\0" unless defined $this->{'_pc'}; |
154 | $this->{'_bc'} = "\b" unless defined $this->{'_bc'}; |
155 | $this; |
a687059c |
156 | } |
157 | |
748a9306 |
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); |
a687059c |
165 | |
a687059c |
166 | if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { |
167 | $ms = $1; |
748a9306 |
168 | $ms *= $cnt if $2; |
a687059c |
169 | $string = $3; |
748a9306 |
170 | $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR}; |
a687059c |
171 | if ($decr > .1) { |
172 | $ms += $decr / 2; |
748a9306 |
173 | $string .= $this->{'_pc'} x ($ms / $decr); |
a687059c |
174 | } |
175 | } |
176 | print $FH $string if $FH; |
177 | $string; |
178 | } |
179 | |
748a9306 |
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); |
a687059c |
211 | sub Tgoto { |
748a9306 |
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 | |
a687059c |
220 | while ($string =~ /^([^%]*)%(.)(.*)/) { |
221 | $result .= $1; |
222 | $code = $2; |
223 | $string = $3; |
224 | if ($code eq 'd') { |
9f68db38 |
225 | $result .= sprintf("%d",shift(@tmp)); |
a687059c |
226 | } |
227 | elsif ($code eq '.') { |
9f68db38 |
228 | $tmp = shift(@tmp); |
a687059c |
229 | if ($tmp == 0 || $tmp == 4 || $tmp == 10) { |
230 | if ($online) { |
748a9306 |
231 | ++$tmp, $after .= $this->{'_up'} if $this->{'_up'}; |
a687059c |
232 | } |
233 | else { |
748a9306 |
234 | ++$tmp, $after .= $this->{'_bc'}; |
a687059c |
235 | } |
236 | } |
237 | $result .= sprintf("%c",$tmp); |
238 | $online = !$online; |
239 | } |
240 | elsif ($code eq '+') { |
9f68db38 |
241 | $result .= sprintf("%c",shift(@tmp)+ord($string)); |
a687059c |
242 | $string = substr($string,1,99); |
243 | $online = !$online; |
244 | } |
245 | elsif ($code eq 'r') { |
9f68db38 |
246 | ($code,$tmp) = @tmp; |
247 | @tmp = ($tmp,$code); |
a687059c |
248 | $online = !$online; |
249 | } |
250 | elsif ($code eq '>') { |
251 | ($code,$tmp,$string) = unpack("CCa99",$string); |
9f68db38 |
252 | if ($tmp[$[] > $code) { |
253 | $tmp[$[] += $tmp; |
a687059c |
254 | } |
255 | } |
256 | elsif ($code eq '2') { |
9f68db38 |
257 | $result .= sprintf("%02d",shift(@tmp)); |
a687059c |
258 | $online = !$online; |
259 | } |
260 | elsif ($code eq '3') { |
9f68db38 |
261 | $result .= sprintf("%03d",shift(@tmp)); |
a687059c |
262 | $online = !$online; |
263 | } |
264 | elsif ($code eq 'i') { |
9f68db38 |
265 | ($code,$tmp) = @tmp; |
266 | @tmp = ($code+1,$tmp+1); |
a687059c |
267 | } |
268 | else { |
269 | return "OOPS"; |
270 | } |
271 | } |
748a9306 |
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 | } |
a687059c |
285 | } |
286 | |
287 | 1; |