Commit | Line | Data |
a0d0e21e |
1 | package Term::Cap; |
85e6fe83 |
2 | require 5.000; |
3 | require Exporter; |
a0d0e21e |
4 | use Carp; |
85e6fe83 |
5 | |
a0d0e21e |
6 | @ISA = qw(Exporter); |
7 | @EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC); |
85e6fe83 |
8 | |
a0d0e21e |
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 | # |
a687059c |
20 | sub Tgetent { |
21 | local($TERM) = @_; |
22 | local($TERMCAP,$_,$entry,$loop,$field); |
23 | |
24 | warn "Tgetent: no ospeed set" unless $ospeed; |
85e6fe83 |
25 | foreach $key (keys(%TC)) { |
a687059c |
26 | delete $TC{$key}; |
27 | } |
28 | $TERM = $ENV{'TERM'} unless $TERM; |
a0d0e21e |
29 | $TERM =~ s/(\W)/\\$1/g; |
a687059c |
30 | $TERMCAP = $ENV{'TERMCAP'}; |
31 | $TERMCAP = '/etc/termcap' unless $TERMCAP; |
32 | if ($TERMCAP !~ m:^/:) { |
7c0587c8 |
33 | if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { |
a687059c |
34 | $TERMCAP = '/etc/termcap'; |
35 | } |
36 | } |
37 | if ($TERMCAP =~ m:^/:) { |
38 | $entry = ''; |
39 | do { |
40 | $loop = " |
a0d0e21e |
41 | open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\"; |
a687059c |
42 | while (<TERMCAP>) { |
43 | next if /^#/; |
44 | next if /^\t/; |
a0d0e21e |
45 | if (/(^|\\|)${TERM}[:\\|]/) { |
a687059c |
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; |
9f68db38 |
59 | } while s/:tc=([^:]+):/:/ && ($TERM = $1); |
a687059c |
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)#(.*)/) { |
85e6fe83 |
68 | $TC{$1} = $2 unless defined $TC{$1}; |
a687059c |
69 | } |
70 | elsif ($field =~ /^(\w\w)=(.*)/) { |
71 | $entry = $1; |
72 | $_ = $2; |
73 | s/\\E/\033/g; |
ecfc5424 |
74 | s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; |
a687059c |
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; |
63f2c1e1 |
82 | s/\^(.)/pack('c',ord($1) & 31)/eg; |
a687059c |
83 | s/\\(.)/$1/g; |
84 | s/\377/^/g; |
85e6fe83 |
85 | $TC{$entry} = $_ unless defined $TC{$entry}; |
a687059c |
86 | } |
87 | } |
85e6fe83 |
88 | $TC{'pc'} = "\0" unless defined $TC{'pc'}; |
89 | $TC{'bc'} = "\b" unless defined $TC{'bc'}; |
a687059c |
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) = @_; |
9f68db38 |
116 | local(@tmp); |
117 | @tmp = ($tmp,$code); |
a687059c |
118 | local($online) = 0; |
119 | while ($string =~ /^([^%]*)%(.)(.*)/) { |
120 | $result .= $1; |
121 | $code = $2; |
122 | $string = $3; |
123 | if ($code eq 'd') { |
9f68db38 |
124 | $result .= sprintf("%d",shift(@tmp)); |
a687059c |
125 | } |
126 | elsif ($code eq '.') { |
9f68db38 |
127 | $tmp = shift(@tmp); |
a687059c |
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 '+') { |
9f68db38 |
140 | $result .= sprintf("%c",shift(@tmp)+ord($string)); |
a687059c |
141 | $string = substr($string,1,99); |
142 | $online = !$online; |
143 | } |
144 | elsif ($code eq 'r') { |
9f68db38 |
145 | ($code,$tmp) = @tmp; |
146 | @tmp = ($tmp,$code); |
a687059c |
147 | $online = !$online; |
148 | } |
149 | elsif ($code eq '>') { |
150 | ($code,$tmp,$string) = unpack("CCa99",$string); |
9f68db38 |
151 | if ($tmp[$[] > $code) { |
152 | $tmp[$[] += $tmp; |
a687059c |
153 | } |
154 | } |
155 | elsif ($code eq '2') { |
9f68db38 |
156 | $result .= sprintf("%02d",shift(@tmp)); |
a687059c |
157 | $online = !$online; |
158 | } |
159 | elsif ($code eq '3') { |
9f68db38 |
160 | $result .= sprintf("%03d",shift(@tmp)); |
a687059c |
161 | $online = !$online; |
162 | } |
163 | elsif ($code eq 'i') { |
9f68db38 |
164 | ($code,$tmp) = @tmp; |
165 | @tmp = ($code+1,$tmp+1); |
a687059c |
166 | } |
167 | else { |
168 | return "OOPS"; |
169 | } |
170 | } |
171 | $result . $string . $after; |
172 | } |
173 | |
174 | 1; |