From 085f5cc492ea5e5475e996a3aeb2a2cd13f949a5 Mon Sep 17 00:00:00 2001 From: Rafael Garcia-Suarez Date: Fri, 19 Oct 2007 10:18:19 +0000 Subject: Upgrade to Term::Cap 1.10 p4raw-id: //depot/perl@32143 --- lib/Term/Cap.pm | 550 +++++++++++++++++++++++++++++++++----------------------- lib/Term/Cap.t | 27 ++- 2 files changed, 348 insertions(+), 229 deletions(-) diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index b71c51ceba..d86e7581b2 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -2,12 +2,14 @@ package Term::Cap; # Since the debugger uses Term::ReadLine which uses Term::Cap, we want # to load as few modules as possible. This includes Carp.pm. -sub carp { +sub carp +{ require Carp; goto &Carp::carp; } -sub croak { +sub croak +{ require Carp; goto &Carp::croak; } @@ -17,7 +19,7 @@ use strict; use vars qw($VERSION $VMS_TERMCAP); use vars qw($termpat $state $first $entry); -$VERSION = '1.09'; +$VERSION = '1.10'; # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com @@ -47,10 +49,13 @@ $VERSION = '1.09'; # Core (Fri Aug 30 14:15:55 CEST 2002): # Cope with comments lines from 'infocmp' from Brendan O'Dea # Allow for EBCDIC in Tgoto magic test. +# Version 1.10: Thu Oct 18 16:52:20 BST 2007 +# Don't use try to use $ENV{HOME} if it doesn't exist +# Give Win32 'dumb' if TERM isn't set +# Provide fallback 'dumb' termcap entry as last resort # TODO: # support Berkeley DB termcaps -# should probably be a .xs module # force $FH into callers package? # keep $FH in object at Tgetent time? @@ -95,36 +100,45 @@ output the string to $FH if specified. # If a different termcap is required then the text of one can be supplied # in $Term::Cap::VMS_TERMCAP before Tgetent is called. -if ( $^O eq 'VMS') { - chomp (my @entry = ); - $VMS_TERMCAP = join '', @entry; +if ( $^O eq 'VMS' ) +{ + chomp( my @entry = ); + $VMS_TERMCAP = join '', @entry; } # Returns a list of termcap files to check. -sub termcap_path { ## private +sub termcap_path +{ ## private my @termcap_path; + # $TERMCAP, if it's a filespec - push(@termcap_path, $ENV{TERMCAP}) - if ((exists $ENV{TERMCAP}) && - (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') - ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is - : $ENV{TERMCAP} =~ /^\//s)); - if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) { - # Add the users $TERMPATH - push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH})) + push( @termcap_path, $ENV{TERMCAP} ) + if ( + ( exists $ENV{TERMCAP} ) + && ( + ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ) + ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is + : $ENV{TERMCAP} =~ /^\//s + ) + ); + if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) ) + { + + # Add the users $TERMPATH + push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) ); } - else { - # Defaults - push(@termcap_path, - $ENV{'HOME'} . '/.termcap', - '/etc/termcap', - '/usr/share/misc/termcap', - ); + else + { + + # Defaults + push( @termcap_path, + exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef, + '/etc/termcap', '/usr/share/misc/termcap', ); } # return the list of those termcaps that exist - return grep(-f, @termcap_path); + return grep { defined $_ && -f $_ } @termcap_path; } =item B @@ -181,94 +195,143 @@ It calls C on failure. =cut -sub Tgetent { ## public -- static method +sub Tgetent +{ ## public -- static method my $class = shift; my ($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 ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP ); + local ( $termpat, $state, $first, $entry ); # used inside eval local $_; # Compute PADDING factor from OSPEED (to be used by Tpad) - if (! $self->{OSPEED}) { - if ( $^W ) { - carp "OSPEED was not set, defaulting to 9600"; + if ( !$self->{OSPEED} ) + { + if ($^W) + { + carp "OSPEED was not set, defaulting to 9600"; } - $self->{OSPEED} = 9600; + $self->{OSPEED} = 9600; } - 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}]; + 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 { - $self->{PADDING} = 10000 / $self->{OSPEED}; + else + { + $self->{PADDING} = 10000 / $self->{OSPEED}; } - $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set"); - $term = $self->{TERM}; # $term is the term type we are looking for + unless ( $self->{TERM} ) + { + if ( $ENV{TERM} ) + { + $self->{TERM} = $ENV{TERM} ; + } + else + { + if ( $^O eq 'Win32' ) + { + $self->{TERM} = 'dumb'; + } + else + { + croak "TERM not set"; + } + } + } + + $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}; - # protect any pattern metacharacters in $tmp_term - $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; - my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : ''); + # 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; + if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) ) + { + $entry = $foo; } my @termcap_path = termcap_path(); - unless (@termcap_path || $entry) + unless ( @termcap_path || $entry ) { - # last resort--fake up a termcap from terminfo - local $ENV{TERM} = $term; - if ( $^O eq 'VMS' ) { - $entry = $VMS_TERMCAP; + # last resort--fake up a termcap from terminfo + local $ENV{TERM} = $term; + + 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; - } - }; - } + 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; + } + }; + } + 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 - # 1 == next file - # 2 == search again + $state = 1; # 0 == finished + # 1 == next file + # 2 == search again - $first = 0; # first entry (keeps term name) + $first = 0; # first entry (keeps term name) - $max = 32; # max :tc=...:'s + $max = 32; # max :tc=...:'s - if ($entry) { - # ok, we're starting with $TERMCAP - $first++; # we're the first entry - # do we need to continue? - if ($entry =~ s/:tc=([^:]+):/:/) { - $tmp_term = $1; - # protect any pattern metacharacters in $tmp_term - $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; - } - else { - $state = 0; # we're already finished - } + if ($entry) + { + + # ok, we're starting with $TERMCAP + $first++; # we're the first entry + # do we need to continue? + if ( $entry =~ s/:tc=([^:]+):/:/ ) + { + $tmp_term = $1; + + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; + $termpat =~ s/(\W)/\\$1/g; + } + else + { + $state = 0; # we're already finished + } } # This is eval'ed inside the while loop for each file @@ -290,70 +353,87 @@ sub Tgetent { ## public -- static method $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 - } + 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; - open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!"; - eval $search; - die $@ if $@; - close TERMCAP; + # If :tc=...: found then search this file again + $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 ); - # 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; + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; + $termpat =~ s/(\W)/\\$1/g; } croak "Can't find $term" if $entry eq ''; - $entry =~ s/:+\s*:+/:/g; # cleanup $entry - $entry =~ s/:+/:/g; # cleanup $entry - $self->{TERMCAP} = $entry; # save it - # print STDERR "DEBUG: $entry = ", $entry, "\n"; + $entry =~ s/:+\s*:+/:/g; # cleanup $entry + $entry =~ s/:+/:/g; # cleanup $entry + $self->{TERMCAP} = $entry; # save it + # print STDERR "DEBUG: $entry = ", $entry, "\n"; # Precompile $entry into the object $entry =~ s/^[^:]*://; - foreach $field (split(/:[\s:\\]*/,$entry)) { - if (defined $field && $field =~ /^(\w\w)$/) { - $self->{'_' . $field} = 1 unless defined $self->{'_' . $1}; - # print STDERR "DEBUG: flag $1\n"; - } - elsif (defined $field && $field =~ /^(\w\w)\@/) { - $self->{'_' . $1} = ""; - # print STDERR "DEBUG: unset $1\n"; - } - elsif (defined $field && $field =~ /^(\w\w)#(.*)/) { - $self->{'_' . $1} = $2 unless defined $self->{'_' . $1}; - # print STDERR "DEBUG: numeric $1 = $2\n"; - } - elsif (defined $field && $field =~ /^(\w\w)=(.*)/) { - # print STDERR "DEBUG: string $1 = $2\n"; - next if defined $self->{'_' . ($cap = $1)}; - $_ = $2; - s/\\E/\033/g; - s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; - s/\\n/\n/g; - s/\\r/\r/g; - s/\\t/\t/g; - s/\\b/\b/g; - s/\\f/\f/g; - s/\\\^/\377/g; - s/\^\?/\177/g; - s/\^(.)/pack('c',ord($1) & 31)/eg; - s/\\(.)/$1/g; - s/\377/^/g; - $self->{'_' . $cap} = $_; - } - # else { carp "junk in $term ignored: $field"; } + foreach $field ( split( /:[\s:\\]*/, $entry ) ) + { + if ( defined $field && $field =~ /^(\w\w)$/ ) + { + $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 }; + + # print STDERR "DEBUG: flag $1\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)\@/ ) + { + $self->{ '_' . $1 } = ""; + + # print STDERR "DEBUG: unset $1\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ ) + { + $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 }; + + # print STDERR "DEBUG: numeric $1 = $2\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ ) + { + + # print STDERR "DEBUG: string $1 = $2\n"; + next if defined $self->{ '_' . ( $cap = $1 ) }; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $self->{ '_' . $cap } = $_; + } + + # else { carp "junk in $term ignored: $field"; } } $self->{'_pc'} = "\0" unless defined $self->{'_pc'}; $self->{'_bc'} = "\b" unless defined $self->{'_bc'}; @@ -391,20 +471,23 @@ The padded $string is returned. =cut -sub Tpad { ## public +sub Tpad +{ ## public my $self = shift; - my($string, $cnt, $FH) = @_; - my($decr, $ms); - - if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) { - $ms = $1; - $ms *= $cnt if $2; - $string = $3; - $decr = $self->{PADDING}; - if ($decr > .1) { - $ms += $decr / 2; - $string .= $self->{'_pc'} x ($ms / $decr); - } + my ( $string, $cnt, $FH ) = @_; + my ( $decr, $ms ); + + if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ ) + { + $ms = $1; + $ms *= $cnt if $2; + $string = $3; + $decr = $self->{PADDING}; + if ( $decr > .1 ) + { + $ms += $decr / 2; + $string .= $self->{'_pc'} x ( $ms / $decr ); + } } print $FH $string if $FH; $string; @@ -440,22 +523,30 @@ The appropriate string for the capability will be returned. =cut -sub Tputs { ## public +sub Tputs +{ ## public my $self = shift; - my($cap, $cnt, $FH) = @_; + my ( $cap, $cnt, $FH ) = @_; my $string; $cnt = 0 unless $cnt; - if ($cnt > 1) { - $string = Tpad($self, $self->{'_' . $cap}, $cnt); - } else { - # cache result because Tpad can be slow - unless (exists $self->{$cap}) { - $self->{$cap} = exists $self->{"_$cap"} ? - Tpad($self, $self->{"_$cap"}, 1) : undef; - } - $string = $self->{$cap}; + if ( $cnt > 1 ) + { + $string = Tpad( $self, $self->{ '_' . $cap }, $cnt ); + } + else + { + + # cache result because Tpad can be slow + unless ( exists $self->{$cap} ) + { + $self->{$cap} = + exists $self->{"_$cap"} + ? Tpad( $self, $self->{"_$cap"}, 1 ) + : undef; + } + $string = $self->{$cap}; } print $FH $string if $FH; $string; @@ -514,69 +605,84 @@ The output string will be returned. =cut -sub Tgoto { ## public +sub Tgoto +{ ## public my $self = shift; - my($cap, $code, $tmp, $FH) = @_; - my $string = $self->{'_' . $cap}; + my ( $cap, $code, $tmp, $FH ) = @_; + my $string = $self->{ '_' . $cap }; my $result = ''; - my $after = ''; + my $after = ''; my $online = 0; - my @tmp = ($tmp,$code); - my $cnt = $code; - - while ($string =~ /^([^%]*)%(.)(.*)/) { - $result .= $1; - $code = $2; - $string = $3; - if ($code eq 'd') { - $result .= sprintf("%d",shift(@tmp)); - } - elsif ($code eq '.') { - $tmp = shift(@tmp); - if ($tmp == 0 || $tmp == 4 || $tmp == 10) { - if ($online) { - ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; - } - else { - ++$tmp, $after .= $self->{'_bc'}; - } - } - $result .= sprintf("%c",$tmp); - $online = !$online; - } - elsif ($code eq '+') { - $result .= sprintf("%c",shift(@tmp)+ord($string)); - $string = substr($string,1,99); - $online = !$online; - } - elsif ($code eq 'r') { - ($code,$tmp) = @tmp; - @tmp = ($tmp,$code); - $online = !$online; - } - elsif ($code eq '>') { - ($code,$tmp,$string) = unpack("CCa99",$string); - if ($tmp[$[] > $code) { - $tmp[$[] += $tmp; - } - } - elsif ($code eq '2') { - $result .= sprintf("%02d",shift(@tmp)); - $online = !$online; - } - elsif ($code eq '3') { - $result .= sprintf("%03d",shift(@tmp)); - $online = !$online; - } - elsif ($code eq 'i') { - ($code,$tmp) = @tmp; - @tmp = ($code+1,$tmp+1); - } - else { - return "OOPS"; - } + my @tmp = ( $tmp, $code ); + my $cnt = $code; + + while ( $string =~ /^([^%]*)%(.)(.*)/ ) + { + $result .= $1; + $code = $2; + $string = $3; + if ( $code eq 'd' ) + { + $result .= sprintf( "%d", shift(@tmp) ); + } + elsif ( $code eq '.' ) + { + $tmp = shift(@tmp); + if ( $tmp == 0 || $tmp == 4 || $tmp == 10 ) + { + if ($online) + { + ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; + } + else + { + ++$tmp, $after .= $self->{'_bc'}; + } + } + $result .= sprintf( "%c", $tmp ); + $online = !$online; + } + elsif ( $code eq '+' ) + { + $result .= sprintf( "%c", shift(@tmp) + ord($string) ); + $string = substr( $string, 1, 99 ); + $online = !$online; + } + elsif ( $code eq 'r' ) + { + ( $code, $tmp ) = @tmp; + @tmp = ( $tmp, $code ); + $online = !$online; + } + elsif ( $code eq '>' ) + { + ( $code, $tmp, $string ) = unpack( "CCa99", $string ); + if ( $tmp[$[] > $code ) + { + $tmp[$[] += $tmp; + } + } + elsif ( $code eq '2' ) + { + $result .= sprintf( "%02d", shift(@tmp) ); + $online = !$online; + } + elsif ( $code eq '3' ) + { + $result .= sprintf( "%03d", shift(@tmp) ); + $online = !$online; + } + elsif ( $code eq 'i' ) + { + ( $code, $tmp ) = @tmp; + @tmp = ( $code + 1, $tmp + 1 ); + } + else + { + return "OOPS"; + } } - $string = Tpad($self, $result . $string . $after, $cnt); + $string = Tpad( $self, $result . $string . $after, $cnt ); print $FH $string if $FH; $string; } @@ -590,12 +696,14 @@ found. =cut -sub Trequire { ## public +sub Trequire +{ ## public my $self = shift; - my($cap,@undefined); - foreach $cap (@_) { - push(@undefined, $cap) - unless defined $self->{'_' . $cap} && $self->{'_' . $cap}; + my ( $cap, @undefined ); + foreach $cap (@_) + { + push( @undefined, $cap ) + unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap }; } croak "Terminal does not support: (@undefined)" if @undefined; } diff --git a/lib/Term/Cap.t b/lib/Term/Cap.t index 0ea537dcdf..08f042ec57 100644 --- a/lib/Term/Cap.t +++ b/lib/Term/Cap.t @@ -24,11 +24,11 @@ my $files = join '', ( $ENV{HOME} . '/.termcap', # we assume pretty UNIXy system anyway '/etc/termcap', '/usr/share/misc/termcap' ); -unless( $files || $^O eq 'VMS') { +unless( $files || $^O eq 'VMS' ) { plan skip_all => 'no termcap available to test'; } else { - plan tests => 44; + plan tests => 45; } use_ok( 'Term::Cap' ); @@ -158,6 +158,17 @@ SKIP: { is( $t->{_bc}, "\b", 'should set _bc field correctly' ); } +# Windows hack +{ + local *^O; + local *ENV; + delete $ENV{TERM}; + $^O = 'Win32'; + + my $foo = Term::Cap->Tgetent(); + is($foo->{TERM} ,'dumb','Windows gets "dumb" by default'); +} + # Tgoto has comments on the expected formats $t->{_test} = "a%d"; is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' ); @@ -166,12 +177,12 @@ is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' ); $t->{_test} = "a%."; like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' ); if (ord('A') == 193) { # EBCDIC platform -like( $t->Tgoto('test', '', 0), qr/\x81\x01\x16/, - 'Tgoto() should handle %. and magic' ); -} else { # ASCII platform -like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, - 'Tgoto() should handle %. and magic' ); -} + like( $t->Tgoto('test', '', 0), qr/\x81\x01\x16/, + 'Tgoto() should handle %. and magic' ); + } else { # ASCII platform + like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, + 'Tgoto() should handle %. and magic' ); + } $t->{_test} = 'a%+'; like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() should handle %+' ); -- cgit v1.2.1