I guess i will probably leave it alone after this.
This does quite a few things compared to my former patches.
- totally get rid of eval, it doen't make sense anymore
- declare variables before they get used, which tends to
simplify things.
- change quaint formatting to something more BSD like
- update documentation to new style of doing OO
- use defined logic on entry and such
- always try to run infocmp as a last resort, even if
we have a path.
- run infocmp with the best options we have to get a good termcap
- use \Q\E, which gets rid of termpat entirely
- dedup the path along the way: for us, /etc/termcap
and /usr/share/misc/termcap are the same.
- redo recursion logic by just recording which term values we
already saw, the max=32 value overflow was absurd, proper parsing
yields roughly 10 or so tc redirections for xterm, not >32.
Index: Cap.pm
===================================================================
RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Term-Cap/Cap.pm,v
retrieving revision 1.3
diff -u -p -r1.3 Cap.pm
--- Cap.pm 18 Oct 2023 01:49:26 -0000 1.3
+++ Cap.pm 20 Oct 2023 09:47:05 -0000
@@ -16,8 +16,8 @@ sub croak
use strict;
+use v5.16;
use vars qw($VERSION $VMS_TERMCAP);
-use vars qw($termpat $state $first $entry);
$VERSION = '1.17';
@@ -33,7 +33,7 @@ Term::Cap - Perl termcap interface
=head1 SYNOPSIS
require Term::Cap;
- $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+ $terminal = Term::Cap->Tgetent({ TERM => undef, OSPEED => $ospeed });
$terminal->Trequire(qw/ce ku kd/);
$terminal->Tgoto('cm', $col, $row, $FH);
$terminal->Tputs('dl', $count, $FH);
@@ -75,10 +75,10 @@ if ( $^O eq 'VMS' )
sub termcap_path
{ ## private
- my @termcap_path;
+ my @l;
# $TERMCAP, if it's a filespec
- push( @termcap_path, $ENV{TERMCAP} )
+ push(@l, $ENV{TERMCAP})
if (
( exists $ENV{TERMCAP} )
&& (
@@ -87,23 +87,27 @@ sub termcap_path
: $ENV{TERMCAP} =~ /^\//s
)
);
- if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
- {
-
+ if (exists $ENV{TERMPATH} && $ENV{TERMPATH}) {
# Add the users $TERMPATH
- push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) );
- }
- else
- {
-
+ push(@l, split( /(:|\s+)/, $ENV{TERMPATH}));
+ } else {
# Defaults
- push( @termcap_path,
- exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
- '/etc/termcap', '/usr/share/misc/termcap', );
+ if (exists $ENV{HOME}) {
+ push(@l, $ENV{HOME}.'/.termcap');
+ }
+ push(@l, '/etc/termcap', '/usr/share/misc/termcap', );
+ }
+ my @termcap_path;
+ my $seen = {};
+ for my $i (@l) {
+ next unless -f $i;
+ my $k = join(',', (stat _)[0,1]);
+ next if $seen->{$k};
+ push(@termcap_path, $i);
+ $seen->{$k} = 1;
}
- # return the list of those termcaps that exist
- return grep { defined $_ && -f $_ } @termcap_path;
+ return @termcap_path;
}
=over 4
@@ -164,195 +168,158 @@ It calls C<croak> on failure.
sub Tgetent
{ ## public -- static method
- my $class = shift;
- my ($self) = @_;
+ my ($class, $self) = @_;
$self = {} unless defined $self;
bless $self, $class;
- my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
- local ( $termpat, $state, $first, $entry ); # used inside eval
+ my ($cap, $field);
+
local $_;
# Compute PADDING factor from OSPEED (to be used by Tpad)
- if ( !$self->{OSPEED} )
- {
- if ($^W)
- {
+ if (!$self->{OSPEED}) {
+ if ($^W) {
carp "OSPEED was not set, defaulting to 9600";
}
$self->{OSPEED} = 9600;
}
- if ( $self->{OSPEED} < 16 )
- {
-
+ if ($self->{OSPEED} < 16) {
# delays for old style speeds
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
);
$self->{PADDING} = $pad[ $self->{OSPEED} ];
- }
- else
- {
+ } else {
$self->{PADDING} = 10000 / $self->{OSPEED};
}
- unless ( $self->{TERM} )
- {
- if ( $ENV{TERM} )
- {
- $self->{TERM} = $ENV{TERM} ;
- }
- else
- {
- if ( $^O eq 'MSWin32' )
- {
+ unless ($self->{TERM}) {
+ if ($ENV{TERM}) {
+ $self->{TERM} = $ENV{TERM} ;
+ } else {
+ if ( $^O eq 'MSWin32' ) {
$self->{TERM} = 'dumb';
- }
- else
- {
+ } else {
croak "TERM not set";
}
}
}
- $term = $self->{TERM}; # $term is the term type we are looking for
+ my $term = $self->{TERM}; # $term is the term type we are looking for
# $tmp_term is always the next term (possibly :tc=...:) we are looking for
- $tmp_term = $self->{TERM};
+ my $tmp_term = $term;
- # protect any pattern metacharacters in $tmp_term
- $termpat = $tmp_term;
- $termpat =~ s/(\W)/\\$1/g;
-
- my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
-
- # $entry is the extracted termcap entry
- if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
- {
- $entry = $foo;
+ my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
+
+ my $seen = {};
+ my $entry;
+ if (exists $ENV{TERMCAP}) {
+ $_ = $ENV{TERMCAP};
+ if ( !m:^/:s && m/(^|\|)\Q$tmp_term\E[:|]/s) {
+ # $entry is the extracted termcap entry
+ $entry = $_;
+ $seen->{$tmp_term} = 1;
+ }
}
my @termcap_path = termcap_path();
+ print "TEMCAP_PATH", join(' ', @termcap_path), "\n";
- if ( !@termcap_path && !$entry )
- {
-
- # last resort--fake up a termcap from terminfo
- local $ENV{TERM} = $term;
-
- if ( $^O eq 'VMS' )
- {
+ if (!@termcap_path && !$entry) {
+ if ( $^O eq 'VMS' ) {
$entry = $VMS_TERMCAP;
- }
- else
- {
- if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
- {
- eval {
- my $tmp = `infocmp -C 2>/dev/null`;
- $tmp =~ s/^#.*\n//gm; # remove comments
- if ( ( $tmp !~ m%^/%s )
- && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
- {
- $entry = $tmp;
- }
- };
- warn "Can't run infocmp to get a termcap entry: $@" if $@;
- }
- else
- {
- # this is getting desperate now
- if ( $self->{TERM} eq 'dumb' )
- {
- $entry = 'dumb|80-column dumb
tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
- }
- }
- }
+ }
}
- croak "Can't find a valid termcap file" unless @termcap_path || $entry;
-
- $state = 1; # 0 == finished
+ my $state = 1; # 0 == finished
# 1 == next file
# 2 == search again
+ # 3 == infocmp
- $first = 0; # first entry (keeps term name)
-
- $max = 64; # max :tc=...:'s
-
- if ($entry)
- {
+ my $first = 0; # first entry (keeps term name)
+ if (defined $entry) {
# ok, we're starting with $TERMCAP
$first++; # we're the first entry
# do we need to continue?
- if ( $entry =~ s/:tc=([^:]+):/:/ )
- {
+ if ($entry =~ s/:tc=([^:]+):/:/ ) {
$tmp_term = $1;
-
- # protect any pattern metacharacters in $tmp_term
- $termpat = $tmp_term;
- $termpat =~ s/(\W)/\\$1/g;
- }
- else
- {
+ } else {
$state = 0; # we're already finished
}
}
- # This is eval'ed inside the while loop for each file
- $search = q{
- while (<TERMCAP>) {
- next if /^\\t/ || /^#/;
- if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
+ my $TERMCAP;
+ while ($state != 0) {
+ if ($state == 1) {
+ # get the next TERMCAP or get ready for infocmp
+ $TERMCAP = shift @termcap_path or $state = 3;
+ } elsif ($state == 3) {
+ croak "failed termcap lookup on $tmp_term";
+ } else {
+ # do the same file again
+ # prevent endless recursion
+ $state = 1; # ok, maybe do a new file next time
+ }
+
+ my ($fh, $child);
+ if ($state == 3) {
+ my $child = open($fh, "-|");
+ # TODO this breaks on !UNIX
+ # not do anything, or let it break here
+ croak "cannot fork: $!" if !defined $child;
+ if (!$child) {
+ open(STDERR, ">", "/dev/null");
+ system('infocmp', '-CTr', $tmp_term);
+ exit(1);
+ }
+ } else {
+ open($fh, "<", $TERMCAP ) || croak "open $TERMCAP: $!";
+ }
+ undef $_;
+ while (<$fh>) {
+ next if /^\t/ || /^#/;
+ if (m/(^|\|)\Q$tmp_term\E[:|]/) {
chomp;
s/^[^:]*:// if $first++;
$state = 0;
- while ($_ =~ s/\\\\$//) {
- defined(my $x = <TERMCAP>) or last;
+ $seen->{$tmp_term} = 1;
+ while (s/\\$//) {
+ defined(my $x = <$fh>) or last;
$_ .= $x; chomp;
}
+ if (defined $entry) {
+ $entry .= $_;
+ } else {
+ $entry = $_;
+ }
last;
}
}
- defined $entry or $entry = '';
- $entry .= $_ if $_;
- };
-
- while ( $state != 0 )
- {
- if ( $state == 1 )
- {
-
- # get the next TERMCAP
- $TERMCAP = shift @termcap_path
- || croak "failed termcap lookup on $tmp_term";
- }
- else
- {
-
- # do the same file again
- # prevent endless recursion
- $max-- || croak "failed termcap loop at $tmp_term";
- $state = 1; # ok, maybe do a new file next time
- }
-
- open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
- eval $search;
- die $@ if $@;
- close TERMCAP;
+ close($fh);
+ waitpid($child, 0) if defined $child;
+ next if !defined $entry;
# If :tc=...: found then search this file again
- $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
-
- # protect any pattern metacharacters in $tmp_term
- $termpat = $tmp_term;
- $termpat =~ s/(\W)/\\$1/g;
+ while ($entry =~ s/:tc=([^:]+):/:/) {
+ $tmp_term = $1;
+ if ($seen->{$tmp_term}) {
+ next;
+ }
+ $state = 2;
+ last;
+ }
}
- croak "Can't find $term" if $entry eq '';
+ if (!defined $entry) {
+ if ($self->{TERM} eq 'dumb') {
+ $entry = 'dumb|80-column dumb
tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
+ }
+ }
+ croak "Can't find $term" if !defined $entry;
$entry =~ s/:+\s*:+/:/g; # cleanup $entry
$entry =~ s/:+/:/g; # cleanup $entry
$self->{TERMCAP} = $entry; # save it
