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