1 # Term::Cap.pm -- Termcap interface routines
4 # Converted to package on 25 Feb 1994 <sanders@bsdi.com>
8 # ioctl(TTY,$TIOCGETP,$sgtty);
9 # ($ispeed,$ospeed) = unpack('cc',$sgtty);
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
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.
37 sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
39 local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
41 if ($v = getenv(TERMPATH)) {
43 @termcap_path = split(':', $v);
46 @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
48 unshift(@termcap_path, $v . '/.termcap') if $v;
50 # we always search TERMCAP first
52 unshift(@termcap_path, $v) if $v =~ /^\//;
53 grep(-f, @termcap_path);
59 local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
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";
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;
72 # handle environment TERMCAP, setup for continuation if needed
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
83 $TERMCAP = shift @termcap_path
84 || die "Tgetent: failed lookup on $TERM\n";
86 $max-- || die "Tgetent: termcap loop at $TERM\n";
87 $state = 1; # back to default state
90 open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
91 # print STDERR "Trying... $TERMCAP\n";
96 if (/(^|\\|)${TERM}[:\\|]/) {
98 s/^[^:]*:// unless \$first++;
100 while (chop eq '\\\\') {
112 #print STDERR "$TERM: $_\n--------\n"; # DEBUG
114 # If :tc=...: found then search this file again
115 $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
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
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};
128 elsif ($field =~ /^(\w\w)\@/) {
129 $this->{'_' . $1} = "";
131 elsif ($field =~ /^(\w\w)#(.*)/) {
132 $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
134 elsif ($field =~ /^(\w\w)=(.*)/) {
135 next if defined $this->{'_' . ($cap = $1)};
138 s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
146 s/\^(.)/pack('c',ord($1) & 31)/eg;
149 $this->{'_' . $cap} = $_;
151 # else { warn "Tgetent: junk in $term: $field\n"; }
153 $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
154 $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
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);
161 # $term->Tpad($string, $cnt, $FH);
163 local($this, $string, $cnt, $FH) = @_;
166 if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
170 $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
173 $string .= $this->{'_pc'} x ($ms / $decr);
176 print $FH $string if $FH;
180 # $term->Tputs($cap, $cnt, $FH);
182 local($this, $cap, $cnt, $FH) = @_;
186 $string = Tpad($this, $this->{'_' . $cap}, $cnt);
188 $string = defined $this->{$cap} ? $this->{$cap} :
189 ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
191 print $FH $string if $FH;
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 %.
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
207 # %n exclusive-or all parameters with 0140 (Datamedia 2500)
208 # %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
210 # $term->Tgoto($cap, $col, $row, $FH);
212 local($this, $cap, $code, $tmp, $FH) = @_;
213 local $string = $this->{'_' . $cap};
217 local @tmp = ($tmp,$code);
220 while ($string =~ /^([^%]*)%(.)(.*)/) {
225 $result .= sprintf("%d",shift(@tmp));
227 elsif ($code eq '.') {
229 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
231 ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
234 ++$tmp, $after .= $this->{'_bc'};
237 $result .= sprintf("%c",$tmp);
240 elsif ($code eq '+') {
241 $result .= sprintf("%c",shift(@tmp)+ord($string));
242 $string = substr($string,1,99);
245 elsif ($code eq 'r') {
250 elsif ($code eq '>') {
251 ($code,$tmp,$string) = unpack("CCa99",$string);
252 if ($tmp[$[] > $code) {
256 elsif ($code eq '2') {
257 $result .= sprintf("%02d",shift(@tmp));
260 elsif ($code eq '3') {
261 $result .= sprintf("%03d",shift(@tmp));
264 elsif ($code eq 'i') {
266 @tmp = ($code+1,$tmp+1);
272 $string = Tpad($this, $result . $string . $after, $cnt);
273 print $FH $string if $FH;
277 # $this->Trequire($cap1, $cap2, ...);
282 die "Trequire: Terminal does not support: $_\n"
283 unless defined $this->{'_' . $_} && $this->{'_' . $_};