perl5.002beta3
[perl.git] / lib / Term / Cap.pm
1 package Term::Cap;
2 use Carp;
3
4 # Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
5
6 # TODO:
7 # support Berkeley DB termcaps
8 # should probably be a .xs module
9 # force $FH into callers package?
10 # keep $FH in object at Tgetent time?
11
12 =head1 NAME
13
14 Term::Cap - Perl termcap interface
15
16 =head1 SYNOPSIS
17
18     require Term::Cap;
19     $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
20     $terminal->Trequire(qw/ce ku kd/);
21     $terminal->Tgoto('cm', $col, $row, $FH);
22     $terminal->Tputs('dl', $count, $FH);
23     $terminal->Tpad($string, $count, $FH);
24
25 =head1 DESCRIPTION
26
27 These are low-level functions to extract and use capabilities from
28 a terminal capability (termcap) database.
29
30 The B<Tgetent> function extracts the entry of the specified terminal
31 type I<TERM> (defaults to the environment variable I<TERM>) from the
32 database.
33
34 It will look in the environment for a I<TERMCAP> variable.  If
35 found, and the value does not begin with a slash, and the terminal
36 type name is the same as the environment string I<TERM>, the
37 I<TERMCAP> string is used instead of reading a termcap file.  If
38 it does begin with a slash, the string is used as a path name of
39 the termcap file to search.  If I<TERMCAP> does not begin with a
40 slash and name is different from I<TERM>, B<Tgetent> searches the
41 files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
42 in that order, unless the environment variable I<TERMPATH> exists,
43 in which case it specifies a list of file pathnames (separated by
44 spaces or colons) to be searched B<instead>.  Whenever multiple
45 files are searched and a tc field occurs in the requested entry,
46 the entry it names must be found in the same file or one of the
47 succeeding files.  If there is a C<:tc=...:> in the I<TERMCAP>
48 environment variable string it will continue the search in the
49 files as above.
50
51 I<OSPEED> is the terminal output bit rate (often mistakenly called
52 the baud rate).  I<OSPEED> can be specified as either a POSIX
53 termios/SYSV termio speeds (where 9600 equals 9600) or an old
54 BSD-style speeds (where 13 equals 9600).
55
56 B<Tgetent> returns a blessed object reference which the user can
57 then use to send the control strings to the terminal using B<Tputs>
58 and B<Tgoto>.  It calls C<croak> on failure.
59
60 B<Tgoto> decodes a cursor addressing string with the given parameters.
61
62 The output strings for B<Tputs> are cached for counts of 1 for performance.
63 B<Tgoto> and B<Tpad> do not cache.  C<$self-E<gt>{_xx}> is the raw termcap
64 data and C<$self-E<gt>{xx}> is the cached version.
65
66     print $terminal->Tpad($self->{_xx}, 1);
67
68 B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
69 output the string to $FH if specified.
70
71 The extracted termcap entry is available in the object
72 as C<$self-E<gt>{TERMCAP}>.
73
74 =head1 EXAMPLES
75
76     # Get terminal output speed
77     require POSIX;
78     my $termios = new POSIX::Termios;
79     $termios->getattr;
80     my $ospeed = $termios->getospeed;
81
82     # Old-style ioctl code to get ospeed:
83     #     require 'ioctl.pl';
84     #     ioctl(TTY,$TIOCGETP,$sgtty);
85     #     ($ispeed,$ospeed) = unpack('cc',$sgtty);
86
87     # allocate and initialize a terminal structure
88     $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
89
90     # require certain capabilities to be available
91     $terminal->Trequire(qw/ce ku kd/);
92
93     # Output Routines, if $FH is undefined these just return the string
94
95     # Tgoto does the % expansion stuff with the given args
96     $terminal->Tgoto('cm', $col, $row, $FH);
97
98     # Tputs doesn't do any % expansion.
99     $terminal->Tputs('dl', $count = 1, $FH);
100
101 =cut
102
103 # Returns a list of termcap files to check.
104 sub termcap_path { ## private
105     my @termcap_path;
106     # $TERMCAP, if it's a filespec
107     push(@termcap_path, $ENV{TERMCAP}) if ((exists $ENV{TERMCAP}) &&
108                                            ($ENV{TERMCAP} =~ /^\//));
109     if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
110         # Add the users $TERMPATH
111         push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
112     }
113     else {
114         # Defaults
115         push(@termcap_path,
116             $ENV{'HOME'} . '/.termcap',
117             '/etc/termcap',
118             '/usr/share/misc/termcap',
119         );
120     }
121     # return the list of those termcaps that exist
122     grep(-f, @termcap_path);
123 }
124
125 sub Tgetent { ## public -- static method
126     my $class = shift;
127     my $self = bless shift, $class;
128     my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
129     local($termpat,$state,$first,$entry);       # used inside eval
130     local $_;
131
132     # Compute PADDING factor from OSPEED (to be used by Tpad)
133     if (! $self->{OSPEED}) {
134         carp "OSPEED was not set, defaulting to 9600";
135         $self->{OSPEED} = 9600;
136     }
137     if ($self->{OSPEED} < 16) {
138         # delays for old style speeds
139         my @pad = (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);
140         $self->{PADDING} = $pad[$self->{OSPEED}];
141     }
142     else {
143         $self->{PADDING} = 10000 / $self->{OSPEED};
144     }
145
146     $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
147     $term = $self->{TERM};      # $term is the term type we are looking for
148
149     # $tmp_term is always the next term (possibly :tc=...:) we are looking for
150     $tmp_term = $self->{TERM};
151     # protect any pattern metacharacters in $tmp_term 
152     $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
153
154     my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
155
156     # $entry is the extracted termcap entry
157     if (($foo !~ m:^/:) && ($foo =~ m/(^|\|)${termpat}[:|]/)) {
158         $entry = $foo;
159     }
160
161     my @termcap_path = termcap_path;
162     croak "Can't find a valid termcap file" unless @termcap_path || $entry;
163
164     $state = 1;                                 # 0 == finished
165                                                 # 1 == next file
166                                                 # 2 == search again
167
168     $first = 0;                                 # first entry (keeps term name)
169
170     $max = 32;                                  # max :tc=...:'s
171
172     if ($entry) {
173         # ok, we're starting with $TERMCAP
174         $first++;                               # we're the first entry
175         # do we need to continue?
176         if ($entry =~ s/:tc=([^:]+):/:/) {
177             $tmp_term = $1;
178             # protect any pattern metacharacters in $tmp_term 
179             $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
180         }
181         else {
182             $state = 0;                         # we're already finished
183         }
184     }
185
186     # This is eval'ed inside the while loop for each file
187     $search = q{
188         while ($_ = <TERMCAP>) {
189             next if /^\\t/ || /^#/;
190             if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
191                 chomp;
192                 s/^[^:]*:// if $first++;
193                 $state = 0;
194                 while ($_ =~ s/\\\\$//) { $_ .= <TERMCAP>; chomp; }
195                 last;
196             }
197         }
198         $entry .= $_;
199     };
200
201     while ($state != 0) {
202         if ($state == 1) {
203             # get the next TERMCAP
204             $TERMCAP = shift @termcap_path
205                 || croak "failed termcap lookup on $tmp_term";
206         }
207         else {
208             # do the same file again
209             # prevent endless recursion
210             $max-- || croak "failed termcap loop at $tmp_term";
211             $state = 1;         # ok, maybe do a new file next time
212         }
213
214         open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
215         eval $search;
216         die $@ if $@;
217         close TERMCAP;
218
219         # If :tc=...: found then search this file again
220         $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
221         # protect any pattern metacharacters in $tmp_term 
222         $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
223     }
224
225     croak "Can't find $term" if $entry eq '';
226     $entry =~ s/:+\s*:+/:/g;                            # cleanup $entry
227     $entry =~ s/:+/:/g;                                 # cleanup $entry
228     $self->{TERMCAP} = $entry;                          # save it
229     # print STDERR "DEBUG: $entry = ", $entry, "\n";
230
231     # Precompile $entry into the object
232     $entry =~ s/^[^:]*://;
233     foreach $field (split(/:[\s:\\]*/,$entry)) {
234         if ($field =~ /^(\w\w)$/) {
235             $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
236             # print STDERR "DEBUG: flag $1\n";
237         }
238         elsif ($field =~ /^(\w\w)\@/) {
239             $self->{'_' . $1} = "";
240             # print STDERR "DEBUG: unset $1\n";
241         }
242         elsif ($field =~ /^(\w\w)#(.*)/) {
243             $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
244             # print STDERR "DEBUG: numeric $1 = $2\n";
245         }
246         elsif ($field =~ /^(\w\w)=(.*)/) {
247             # print STDERR "DEBUG: string $1 = $2\n";
248             next if defined $self->{'_' . ($cap = $1)};
249             $_ = $2;
250             s/\\E/\033/g;
251             s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
252             s/\\n/\n/g;
253             s/\\r/\r/g;
254             s/\\t/\t/g;
255             s/\\b/\b/g;
256             s/\\f/\f/g;
257             s/\\\^/\377/g;
258             s/\^\?/\177/g;
259             s/\^(.)/pack('c',ord($1) & 31)/eg;
260             s/\\(.)/$1/g;
261             s/\377/^/g;
262             $self->{'_' . $cap} = $_;
263         }
264         # else { carp "junk in $term ignored: $field"; }
265     }
266     $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
267     $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
268     $self;
269 }
270
271 # $terminal->Tpad($string, $cnt, $FH);
272 sub Tpad { ## public
273     my $self = shift;
274     my($string, $cnt, $FH) = @_;
275     my($decr, $ms);
276
277     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
278         $ms = $1;
279         $ms *= $cnt if $2;
280         $string = $3;
281         $decr = $self->{PADDING};
282         if ($decr > .1) {
283             $ms += $decr / 2;
284             $string .= $self->{'_pc'} x ($ms / $decr);
285         }
286     }
287     print $FH $string if $FH;
288     $string;
289 }
290
291 # $terminal->Tputs($cap, $cnt, $FH);
292 sub Tputs { ## public
293     my $self = shift;
294     my($cap, $cnt, $FH) = @_;
295     my $string;
296
297     if ($cnt > 1) {
298         $string = Tpad($self, $self->{'_' . $cap}, $cnt);
299     } else {
300         # cache result because Tpad can be slow
301         $string = defined $self->{$cap} ? $self->{$cap} :
302             ($self->{$cap} = Tpad($self, $self->{'_' . $cap}, 1));
303     }
304     print $FH $string if $FH;
305     $string;
306 }
307
308 # %%   output `%'
309 # %d   output value as in printf %d
310 # %2   output value as in printf %2d
311 # %3   output value as in printf %3d
312 # %.   output value as in printf %c
313 # %+x  add x to value, then do %.
314 #
315 # %>xy if value > x then add y, no output
316 # %r   reverse order of two parameters, no output
317 # %i   increment by one, no output
318 # %B   BCD (16*(value/10)) + (value%10), no output
319 #
320 # %n   exclusive-or all parameters with 0140 (Datamedia 2500)
321 # %D   Reverse coding (value - 2*(value%16)), no output (Delta Data)
322 #
323 # $terminal->Tgoto($cap, $col, $row, $FH);
324 sub Tgoto { ## public
325     my $self = shift;
326     my($cap, $code, $tmp, $FH) = @_;
327     my $string = $self->{'_' . $cap};
328     my $result = '';
329     my $after = '';
330     my $online = 0;
331     my @tmp = ($tmp,$code);
332     my $cnt = $code;
333
334     while ($string =~ /^([^%]*)%(.)(.*)/) {
335         $result .= $1;
336         $code = $2;
337         $string = $3;
338         if ($code eq 'd') {
339             $result .= sprintf("%d",shift(@tmp));
340         }
341         elsif ($code eq '.') {
342             $tmp = shift(@tmp);
343             if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
344                 if ($online) {
345                     ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
346                 }
347                 else {
348                     ++$tmp, $after .= $self->{'_bc'};
349                 }
350             }
351             $result .= sprintf("%c",$tmp);
352             $online = !$online;
353         }
354         elsif ($code eq '+') {
355             $result .= sprintf("%c",shift(@tmp)+ord($string));
356             $string = substr($string,1,99);
357             $online = !$online;
358         }
359         elsif ($code eq 'r') {
360             ($code,$tmp) = @tmp;
361             @tmp = ($tmp,$code);
362             $online = !$online;
363         }
364         elsif ($code eq '>') {
365             ($code,$tmp,$string) = unpack("CCa99",$string);
366             if ($tmp[$[] > $code) {
367                 $tmp[$[] += $tmp;
368             }
369         }
370         elsif ($code eq '2') {
371             $result .= sprintf("%02d",shift(@tmp));
372             $online = !$online;
373         }
374         elsif ($code eq '3') {
375             $result .= sprintf("%03d",shift(@tmp));
376             $online = !$online;
377         }
378         elsif ($code eq 'i') {
379             ($code,$tmp) = @tmp;
380             @tmp = ($code+1,$tmp+1);
381         }
382         else {
383             return "OOPS";
384         }
385     }
386     $string = Tpad($self, $result . $string . $after, $cnt);
387     print $FH $string if $FH;
388     $string;
389 }
390
391 # $terminal->Trequire(qw/ce ku kd/);
392 sub Trequire { ## public
393     my $self = shift;
394     my($cap,@undefined);
395     foreach $cap (@_) {
396         push(@undefined, $cap)
397             unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
398     }
399     croak "Terminal does not support: (@undefined)" if @undefined;
400 }
401
402 1;
403