summaryrefslogtreecommitdiffstats
path: root/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm')
-rw-r--r--gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm155
1 files changed, 97 insertions, 58 deletions
diff --git a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm
index 98974e2518f..787353ba588 100644
--- a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm
+++ b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm
@@ -12,7 +12,8 @@ use File::Spec::Functions qw(catfile catdir splitdir);
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.23_01';
+$VERSION = '3.25_03'; # patched in perl5.git
+$VERSION =~ s/_//;
#..........................................................................
@@ -69,6 +70,7 @@ BEGIN {
*is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin;
*is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux;
*is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux;
+ *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos;
}
$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
@@ -432,6 +434,16 @@ sub init {
# Make sure creat()s are neither too much nor too little
eval { umask(0077) }; # doubtless someone has no mask
+ if ( $] < 5.008 ) {
+ $self->aside("Your old perl doesn't have proper unicode support.");
+ }
+ else {
+ # http://www.perl.com/pub/2012/04/perlunicookbook-decode-argv-as-utf8.html
+ # Decode command line arguments as UTF-8. See RT#98906 for example problem.
+ use Encode qw(decode_utf8);
+ @ARGV = map { decode_utf8($_, 1) } @ARGV;
+ }
+
$self->{'args'} ||= \@ARGV;
$self->{'found'} ||= [];
$self->{'temp_file_list'} ||= [];
@@ -474,7 +486,7 @@ sub init_formatter_class_list {
$self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
$self->opt_o_with('text');
- $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos
+ $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
@@ -942,7 +954,7 @@ sub maybe_generate_dynamic_pod {
$self->aside("Hm, I found some Pod from that search!\n");
my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
if ( $] >= 5.008 && $self->opt_L ) {
- binmode($buffd, ":utf8");
+ binmode($buffd, ":encoding(UTF-8)");
print $buffd "=encoding utf8\n\n";
}
@@ -1033,6 +1045,33 @@ sub add_translator { # $self->add_translator($lang);
#..........................................................................
+sub open_fh {
+ my ($self, $op, $path) = @_;
+
+ open my $fh, $op, $path or $self->die("Couldn't open $path: $!");
+ return $fh;
+}
+
+sub set_encoding {
+ my ($self, $fh, $encoding) = @_;
+
+ if ( $encoding =~ /utf-?8/i ) {
+ $encoding = ":encoding(UTF-8)";
+ }
+ else {
+ $encoding = ":encoding($encoding)";
+ }
+
+ if ( $] < 5.008 ) {
+ $self->aside("Your old perl doesn't have proper unicode support.");
+ }
+ else {
+ binmode($fh, $encoding);
+ }
+
+ return $fh;
+}
+
sub search_perlvar {
my($self, $found_things, $pod) = @_;
@@ -1045,8 +1084,7 @@ sub search_perlvar {
DEBUG > 2 and print "Search: @$found_things\n";
my $perlvar = shift @$found_things;
- open(PVAR, "<", $perlvar) # "Funk is its own reward"
- or $self->die("Can't open $perlvar: $!");
+ my $fh = $self->open_fh("<", $perlvar);
if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
$opt = '$<I<digits>>';
@@ -1058,15 +1096,19 @@ sub search_perlvar {
# Skip introduction
local $_;
- while (<PVAR>) {
+ my $enc;
+ while (<$fh>) {
+ $enc = $1 if /^=encoding\s+(\S+)/;
last if /^=over 8/;
}
+ $fh = $self->set_encoding($fh, $enc) if $enc;
+
# Look for our variable
my $found = 0;
my $inheader = 1;
my $inlist = 0;
- while (<PVAR>) { # "The Mothership Connection is here!"
+ while (<$fh>) {
last if /^=head2 Error Indicators/;
# \b at the end of $` and friends borks things!
if ( m/^=item\s+$search_re\s/ ) {
@@ -1100,7 +1142,7 @@ sub search_perlvar {
if (!@$pod) {
CORE::die( "No documentation for perl variable '$opt' found\n" );
}
- close PVAR or $self->die( "Can't open $perlvar: $!" );
+ close $fh or $self->die( "Can't close $perlvar: $!" );
return;
}
@@ -1116,7 +1158,7 @@ sub search_perlop {
# XXX FIXME: getting filehandles should probably be done in a single place
# especially since we need to support UTF8 or other encoding when dealing
# with perlop, perlfunc, perlapi, perlfaq[1-9]
- open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" );
+ my $fh = $self->open_fh('<', $perlop);
my $thing = $self->opt_f;
@@ -1125,7 +1167,8 @@ sub search_perlop {
my $seen_item = 0;
my $skip = 1;
- while( my $line = <PERLOP> ) {
+ while( my $line = <$fh> ) {
+ $line =~ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
# only start search after we hit the operator section
if ($line =~ m!^X<operator, regexp>!) {
$skip = 0;
@@ -1179,7 +1222,7 @@ sub search_perlop {
DEBUG > 4 and print "No pod from perlop\n";
}
- close PERLOP;
+ close $fh;
return;
}
@@ -1192,25 +1235,13 @@ sub search_perlapi {
DEBUG > 2 and print "Search: @$found_things\n";
my $perlapi = shift @$found_things;
- open(PAPI, "<", $perlapi) # "Funk is its own reward"
- or $self->die("Can't open $perlapi: $!");
+ my $fh = $self->open_fh('<', $perlapi);
my $search_re = quotemeta($self->opt_a);
DEBUG > 2 and
print "Going to perlapi-scan for $search_re in $perlapi\n";
- # Check available translator or backup to default (english)
- if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
- my $tr = $self->{'translators'}->[0];
- if ( $] < 5.008 ) {
- $self->aside("Your old perl doesn't really have proper unicode support.");
- }
- else {
- binmode(PAPI, ":utf8");
- }
- }
-
local $_;
# Look for our function
@@ -1219,7 +1250,9 @@ sub search_perlapi {
my @related;
my $related_re;
- while (<PAPI>) { # "The Mothership Connection is here!"
+ while (<$fh>) {
+ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
+
if ( m/^=item\s+$search_re\b/ ) {
$found = 1;
}
@@ -1256,7 +1289,7 @@ sub search_perlapi {
$self->opt_a )
;
}
- close PAPI or $self->die( "Can't open $perlapi: $!" );
+ close $fh or $self->die( "Can't open $perlapi: $!" );
return;
}
@@ -1268,16 +1301,15 @@ sub search_perlfunc {
DEBUG > 2 and print "Search: @$found_things\n";
- my $perlfunc = shift @$found_things;
- open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
- or $self->die("Can't open $perlfunc: $!");
+ my $pfunc = shift @$found_things;
+ my $fh = $self->open_fh("<", $pfunc); # "Funk is its own reward"
# Functions like -r, -e, etc. are listed under `-X'.
my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
? '(?:I<)?-X' : quotemeta($self->opt_f) ;
DEBUG > 2 and
- print "Going to perlfunc-scan for $search_re in $perlfunc\n";
+ print "Going to perlfunc-scan for $search_re in $pfunc\n";
my $re = 'Alphabetical Listing of Perl Functions';
@@ -1288,14 +1320,12 @@ sub search_perlfunc {
if ( $] < 5.008 ) {
$self->aside("Your old perl doesn't really have proper unicode support.");
}
- else {
- binmode(PFUNC, ":utf8");
- }
}
# Skip introduction
local $_;
- while (<PFUNC>) {
+ while (<$fh>) {
+ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
last if /^=head2 $re/;
}
@@ -1307,7 +1337,7 @@ sub search_perlfunc {
my @related;
my $related_re;
- while (<PFUNC>) { # "The Mothership Connection is here!"
+ while (<$fh>) { # "The Mothership Connection is here!"
last if( grep{ $self->opt_f eq $_ }@perlops );
if ( /^=over/ and not $found ) {
@@ -1357,7 +1387,7 @@ sub search_perlfunc {
$self->opt_f )
;
}
- close PFUNC or $self->die( "Can't close $perlfunc: $!" );
+ close $fh or $self->die( "Can't close $pfunc: $!" );
return;
}
@@ -1382,9 +1412,9 @@ EOD
local $_;
foreach my $file (@$found_things) {
$self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
- open(INFAQ, "<", $file) # XXX 5.6ism
- or $self->die( "Can't read-open $file: $!\nAborting" );
- while (<INFAQ>) {
+ my $fh = $self->open_fh("<", $file);
+ while (<$fh>) {
+ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
if ( m/^=head2\s+.*(?:$search_key)/i ) {
$found = 1;
push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
@@ -1395,7 +1425,7 @@ EOD
next unless $found;
push @$pod, $_;
}
- close(INFAQ);
+ close($fh);
}
CORE::die("No documentation for perl FAQ keyword '$search_key' found\n")
unless @$pod;
@@ -1619,6 +1649,9 @@ sub minus_f_nocase { # i.e., do like -f, but without regard to case
#..........................................................................
sub pagers_guessing {
+ # TODO: This whole subroutine needs to be rewritten. It's semi-insane
+ # right now.
+
my $self = shift;
my @pagers;
@@ -1636,6 +1669,10 @@ sub pagers_guessing {
push @pagers, qw( less.exe more.com< );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
+ elsif ( $self->is_amigaos) {
+ push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE );
+ unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER};
+ }
else {
if ($self->is_os2) {
unshift @pagers, 'less', 'cmd /c more <';
@@ -1655,6 +1692,7 @@ sub pagers_guessing {
unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER}
}
else {
+ unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER};
unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER};
}
@@ -1734,9 +1772,9 @@ sub isprintable {
my $data;
local($_);
- open(TEST,"<", $file) or $self->die( "Can't open $file: $!" );
- read TEST, $data, $size;
- close TEST;
+ my $fh = $self->open_fh("<", $file);
+ read $fh, $data, $size;
+ close $fh;
$size= length($data);
$data =~ tr/\x09-\x0D\x20-\x7E//d;
return length($data) <= $size*$maxunprintfrac;
@@ -1769,14 +1807,14 @@ sub containspod {
}
local($_);
- open(TEST,"<", $file) or $self->die( "Can't open $file: $!" ); # XXX 5.6ism
- while (<TEST>) {
+ my $fh = $self->open_fh("<", $file);
+ while (<$fh>) {
if (/^=head/) {
- close(TEST) or $self->die( "Can't close $file: $!" );
+ close($fh) or $self->die( "Can't close $file: $!" );
return 1;
}
}
- close(TEST) or $self->die( "Can't close $file: $!" );
+ close($fh) or $self->die( "Can't close $file: $!" );
return 0;
}
@@ -1812,15 +1850,8 @@ sub new_output_file {
# Otherwise open a write-handle on opt_d!f
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($^V < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
- $self->die( "Can't write-open $outspec: $!" )
- unless open($fh, ">", $outspec); # XXX 5.6ism
+ my $fh = $self->open_fh(">", $outspec);
DEBUG > 3 and print "Successfully opened $outspec\n";
binmode($fh) if $self->{'output_is_binary'};
@@ -1874,12 +1905,12 @@ sub page { # apply a pager to the output file
my ($self, $output, $output_to_stdout, @pagers) = @_;
if ($output_to_stdout) {
$self->aside("Sending unpaged output to STDOUT.\n");
- open(TMP, "<", $output) or $self->die( "Can't open $output: $!" ); # XXX 5.6ism
+ my $fh = $self->open_fh("<", $output);
local $_;
- while (<TMP>) {
+ while (<$fh>) {
print or $self->die( "Can't print to stdout: $!" );
}
- close TMP or $self->die( "Can't close while $output: $!" );
+ close $fh or $self->die( "Can't close while $output: $!" );
$self->unlink_if_temp_file($output);
} else {
# On VMS, quoting prevents logical expansion, and temp files with no
@@ -1892,11 +1923,19 @@ sub page { # apply a pager to the output file
# many many corners of the OS don't like it. So we
# have to force it to be "\" to make everyone happy.
+ # if we are on an amiga convert unix path to an amiga one
+ $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos;
+
foreach my $pager (@pagers) {
$self->aside("About to try calling $pager $output\n");
if ($self->is_vms) {
last if system("$pager $output") == 0;
+ } elsif($self->is_amigaos) {
+ last if system($pager, $output) == 0;
} else {
+ # fix visible escape codes in ToTerm output
+ # https://bugs.debian.org/758689
+ local $ENV{LESS} = defined $ENV{LESS} ? "$ENV{LESS} -R" : "-R";
last if system("$pager \"$output\"") == 0;
}
}
Copyright © 1996 – 2023 Jason A. Donenfeld. All Rights Reverse Engineered.