Current File : //proc/thread-self/root/proc/self/root/proc/self/root/usr/share/perl5/vendor_perl/Pod/Perldoc.pm
use 5.006; # we use some open(X, "<", $y) syntax
package Pod::Perldoc;
use strict;
use warnings;
use Config '%Config';
use Fcntl; # for sysopen
use File::Basename qw(basename);
use File::Spec::Functions qw(catfile catdir splitdir);
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
$VERSION = '3.28';
#..........................................................................
BEGIN { # Make a DEBUG constant very first thing...
unless(defined &DEBUG) {
if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
eval("sub DEBUG () {$1}");
die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
} else {
*DEBUG = sub () {0};
}
}
}
use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
use Carp qw(croak carp);
# these are also in BaseTo, which I don't want to inherit
sub debugging {
my $self = shift;
( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() )
}
sub debug {
my( $self, @messages ) = @_;
return unless $self->debugging;
print STDERR map { "DEBUG : $_" } @messages;
}
sub warn {
my( $self, @messages ) = @_;
carp( join "\n", @messages, '' );
}
sub die {
my( $self, @messages ) = @_;
croak( join "\n", @messages, '' );
}
#..........................................................................
sub TRUE () {1}
sub FALSE () {return}
sub BE_LENIENT () {1}
BEGIN {
*is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms;
*is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
*is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos;
*is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2;
*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;
# If it's older than five days, it's quite unlikely
# that anyone's still looking at it!!
# (Currently used only by the MSWin cleanup routine)
#..........................................................................
{ my $pager = $Config{'pager'};
push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms;
}
$Bindir = $Config{'scriptdirexp'};
$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
# End of class-init stuff
#
###########################################################################
#
# Option accessors...
foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULva}) {
no strict 'refs';
*$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
}
# And these are so that GetOptsOO knows they take options:
sub opt_a_with { shift->_elem('opt_a', @_) }
sub opt_f_with { shift->_elem('opt_f', @_) }
sub opt_q_with { shift->_elem('opt_q', @_) }
sub opt_d_with { shift->_elem('opt_d', @_) }
sub opt_L_with { shift->_elem('opt_L', @_) }
sub opt_v_with { shift->_elem('opt_v', @_) }
sub opt_w_with { # Specify an option for the formatter subclass
my($self, $value) = @_;
if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
my $option = $1;
my $option_value = defined($2) ? $2 : "TRUE";
$option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
$self->add_formatter_option( $option, $option_value );
} else {
$self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) );
}
return;
}
sub opt_M_with { # specify formatter class name(s)
my($self, $classes) = @_;
return unless defined $classes and length $classes;
DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
my @classes_to_add;
foreach my $classname (split m/[,;]+/s, $classes) {
next unless $classname =~ m/\S/;
if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
# A mildly restrictive concept of what modulenames are valid.
push @classes_to_add, $1; # untaint
} else {
$self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) );
}
}
unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
DEBUG > 3 and print(
"Adding @classes_to_add to the list of formatter classes, "
. "making them @{ $self->{'formatter_classes'} }.\n"
);
return;
}
sub opt_V { # report version and exit
print join '',
"Perldoc v$VERSION, under perl v$] for $^O",
(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
(chr(65) eq 'A') ? () : " (non-ASCII)",
"\n",
;
exit;
}
sub opt_t { # choose plaintext as output format
my $self = shift;
$self->opt_o_with('text') if @_ and $_[0];
return $self->_elem('opt_t', @_);
}
sub opt_u { # choose raw pod as output format
my $self = shift;
$self->opt_o_with('pod') if @_ and $_[0];
return $self->_elem('opt_u', @_);
}
sub opt_n_with {
# choose man as the output format, and specify the proggy to run
my $self = shift;
$self->opt_o_with('man') if @_ and $_[0];
$self->_elem('opt_n', @_);
}
sub opt_o_with { # "o" for output format
my($self, $rest) = @_;
return unless defined $rest and length $rest;
if($rest =~ m/^(\w+)$/s) {
$rest = $1; #untaint
} else {
$self->warn( qq("$rest" isn't a valid output format. Skipping.\n") );
return;
}
$self->aside("Noting \"$rest\" as desired output format...\n");
# Figure out what class(es) that could actually mean...
my @classes;
foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
# Messy but smart:
foreach my $stem (
$rest, # Yes, try it first with the given capitalization
"\L$rest", "\L\u$rest", "\U$rest" # And then try variations
) {
$self->aside("Considering $prefix$stem\n");
push @classes, $prefix . $stem;
}
# Tidier, but misses too much:
#push @classes, $prefix . ucfirst(lc($rest));
}
$self->opt_M_with( join ";", @classes );
return;
}
###########################################################################
# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
sub run { # to be called by the "perldoc" executable
my $class = shift;
if(DEBUG > 3) {
print "Parameters to $class\->run:\n";
my @x = @_;
while(@x) {
$x[1] = '<undef>' unless defined $x[1];
$x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
print " [$x[0]] => [$x[1]]\n";
splice @x,0,2;
}
print "\n";
}
return $class -> new(@_) -> process() || 0;
}
# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
###########################################################################
sub new { # yeah, nothing fancy
my $class = shift;
my $new = bless {@_}, (ref($class) || $class);
DEBUG > 1 and print "New $class object $new\n";
$new->init();
$new;
}
#..........................................................................
sub aside { # If we're in -D or DEBUG mode, say this.
my $self = shift;
if( DEBUG or $self->opt_D ) {
my $out = join( '',
DEBUG ? do {
my $callsub = (caller(1))[3];
my $package = quotemeta(__PACKAGE__ . '::');
$callsub =~ s/^$package/'/os;
# the o is justified, as $package really won't change.
$callsub . ": ";
} : '',
@_,
);
if(DEBUG) { print $out } else { print STDERR $out }
}
return;
}
#..........................................................................
sub usage {
my $self = shift;
$self->warn( "@_\n" ) if @_;
# Erase evidence of previous errors (if any), so exit status is simple.
$! = 0;
CORE::die( <<EOF );
perldoc [options] PageName|ModuleName|ProgramName|URL...
perldoc [options] -f BuiltinFunction
perldoc [options] -q FAQRegex
perldoc [options] -v PerlVariable
Options:
-h Display this help message
-V Report version
-r Recursive search (slow)
-i Ignore case
-t Display pod using pod2text instead of Pod::Man and groff
(-t is the default on win32 unless -n is specified)
-u Display unformatted pod text
-m Display module's file in its entirety
-n Specify replacement for groff
-l Display the module's file name
-U Don't attempt to drop privs for security
-F Arguments are file names, not modules (implies -U)
-D Verbosely describe what's going on
-T Send output to STDOUT without any pager
-d output_filename_to_send_to
-o output_format_name
-M FormatterModuleNameToUse
-w formatter_option:option_value
-L translation_code Choose doc translation (if any)
-X Use index if present (looks for pod.idx at $Config{archlib})
-q Search the text of questions (not answers) in perlfaq[1-9]
-f Search Perl built-in functions
-a Search Perl API
-v Search predefined Perl variables
PageName|ModuleName|ProgramName|URL...
is the name of a piece of documentation that you want to look at. You
may either give a descriptive name of the page (as in the case of
`perlfunc') the name of a module, either like `Term::Info' or like
`Term/Info', or the name of a program, like `perldoc', or a URL
starting with http(s).
BuiltinFunction
is the name of a perl function. Will extract documentation from
`perlfunc' or `perlop'.
FAQRegex
is a regex. Will search perlfaq[1-9] for and extract any
questions that match.
Any switches in the PERLDOC environment variable will be used before the
command line arguments. The optional pod index file contains a list of
filenames, one per line.
[Perldoc v$VERSION]
EOF
}
#..........................................................................
sub program_name {
my( $self ) = @_;
if( my $link = readlink( $0 ) ) {
$self->debug( "The value in $0 is a symbolic link to $link\n" );
}
my $basename = basename( $0 );
$self->debug( "\$0 is [$0]\nbasename is [$basename]\n" );
# possible name forms
# perldoc
# perldoc-v5.14
# perldoc-5.14
# perldoc-5.14.2
# perlvar # an alias mentioned in Camel 3
{
my( $untainted ) = $basename =~ m/(
\A
perl
(?: doc | func | faq | help | op | toc | var # Camel 3
)
(?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version
(?: \. (?: bat | exe | com ) )? # possible extension
\z
)
/x;
$self->debug($untainted);
return $untainted if $untainted;
}
$self->warn(<<"HERE");
You called the perldoc command with a name that I didn't recognize.
This might mean that someone is tricking you into running a
program you don't intend to use, but it also might mean that you
created your own link to perldoc. I think your program name is
[$basename].
I'll allow this if the filename only has [a-zA-Z0-9._-].
HERE
{
my( $untainted ) = $basename =~ m/(
\A [a-zA-Z0-9._-]+ \z
)/x;
$self->debug($untainted);
return $untainted if $untainted;
}
$self->die(<<"HERE");
I think that your name for perldoc is potentially unsafe, so I'm
going to disallow it. I'd rather you be safe than sorry. If you
intended to use the name I'm disallowing, please tell the maintainers
about it. Write to:
Pod-Perldoc\@rt.cpan.org
HERE
}
#..........................................................................
sub usage_brief {
my $self = shift;
my $program_name = $self->program_name;
CORE::die( <<"EOUSAGE" );
Usage: $program_name [-hVriDtumUFXlT] [-n nroffer_program]
[-d output_filename] [-o output_format] [-M FormatterModule]
[-w formatter_option:option_value] [-L translation_code]
PageName|ModuleName|ProgramName
Examples:
$program_name -f PerlFunc
$program_name -q FAQKeywords
$program_name -v PerlVar
$program_name -a PerlAPI
The -h option prints more help. Also try "$program_name perldoc" to get
acquainted with the system. [Perldoc v$VERSION]
EOUSAGE
}
#..........................................................................
sub pagers { @{ shift->{'pagers'} } }
#..........................................................................
sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
else { return $_[0]{ $_[1] } }
}
#..........................................................................
###########################################################################
#
# Init formatter switches, and start it off with __bindir and all that
# other stuff that ToMan.pm needs.
#
sub init {
my $self = shift;
# 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'} ||= [];
$self->{'target'} = undef;
$self->init_formatter_class_list;
$self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
$self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
$self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
$self->{'search_path'} = [ ] unless exists $self->{'search_path'};
push @{ $self->{'formatter_switches'} = [] }, (
# Yeah, we could use a hashref, but maybe there's some class where options
# have to be ordered; so we'll use an arrayref.
[ '__bindir' => $self->{'bindir' } ],
[ '__pod2man' => $self->{'pod2man'} ],
);
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
$self->{'translators'} = [];
$self->{'extra_search_dirs'} = [];
return;
}
#..........................................................................
sub init_formatter_class_list {
my $self = shift;
$self->{'formatter_classes'} ||= [];
# Remember, no switches have been read yet, when
# we've started this routine.
$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->is_amigaos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
return;
}
#..........................................................................
sub process {
# if this ever returns, its retval will be used for exit(RETVAL)
my $self = shift;
DEBUG > 1 and print " Beginning process.\n";
DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
if(DEBUG > 3) {
print "Object contents:\n";
my @x = %$self;
while(@x) {
$x[1] = '<undef>' unless defined $x[1];
$x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
print " [$x[0]] => [$x[1]]\n";
splice @x,0,2;
}
print "\n";
}
# TODO: make it deal with being invoked as various different things
# such as perlfaq".
return $self->usage_brief unless @{ $self->{'args'} };
$self->options_reading;
$self->pagers_guessing;
$self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
$self->drop_privs_maybe unless ($self->opt_U || $self->opt_F);
$self->options_processing;
# Hm, we have @pages and @found, but we only really act on one
# file per call, with the exception of the opt_q hack, and with
# -l things
$self->aside("\n");
my @pages;
$self->{'pages'} = \@pages;
if( $self->opt_f) { @pages = qw(perlfunc perlop) }
elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
elsif( $self->opt_v) { @pages = ("perlvar") }
elsif( $self->opt_a) { @pages = ("perlapi") }
else { @pages = @{$self->{'args'}};
# @pages = __FILE__
# if @pages == 1 and $pages[0] eq 'perldoc';
}
return $self->usage_brief unless @pages;
$self->find_good_formatter_class();
$self->formatter_sanity_check();
$self->maybe_extend_searchpath();
# for when we're apparently in a module or extension directory
my @found = $self->grand_search_init(\@pages);
exit ($self->is_vms ? 98962 : 1) unless @found;
if ($self->opt_l and not $self->opt_q ) {
DEBUG and print "We're in -l mode, so byebye after this:\n";
print join("\n", @found), "\n";
return;
}
$self->tweak_found_pathnames(\@found);
$self->assert_closing_stdout;
return $self->page_module_file(@found) if $self->opt_m;
DEBUG > 2 and print "Found: [@found]\n";
return $self->render_and_page(\@found);
}
#..........................................................................
{
my( %class_seen, %class_loaded );
sub find_good_formatter_class {
my $self = $_[0];
my @class_list = @{ $self->{'formatter_classes'} || [] };
$self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list;
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
my $good_class_found;
foreach my $c (@class_list) {
DEBUG > 4 and print "Trying to load $c...\n";
if($class_loaded{$c}) {
DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
$good_class_found = $c;
last;
}
if($class_seen{$c}) {
DEBUG > 4 and print
"I've tried $c before, and it's no good. Skipping.\n";
next;
}
$class_seen{$c} = 1;
if( $c->can('parse_from_file') ) {
DEBUG > 4 and print
"Interesting, the formatter class $c is already loaded!\n";
} elsif(
( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2)
# the always case-insensitive filesystems
and $class_seen{lc("~$c")}++
) {
DEBUG > 4 and print
"We already used something quite like \"\L$c\E\", so no point using $c\n";
# This avoids redefining the package.
} else {
DEBUG > 4 and print "Trying to eval 'require $c'...\n";
local $^W = $^W;
if(DEBUG() or $self->opt_D) {
# feh, let 'em see it
} else {
$^W = 0;
# The average user just has no reason to be seeing
# $^W-suppressible warnings from the require!
}
eval "require $c";
if($@) {
DEBUG > 4 and print "Couldn't load $c: $!\n";
next;
}
}
if( $c->can('parse_from_file') ) {
DEBUG > 4 and print "Settling on $c\n";
my $v = $c->VERSION;
$v = ( defined $v and length $v ) ? " version $v" : '';
$self->aside("Formatter class $c$v successfully loaded!\n");
$good_class_found = $c;
last;
} else {
DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
}
}
$self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" )
unless $good_class_found;
$self->{'formatter_class'} = $good_class_found;
$self->aside("Will format with the class $good_class_found\n");
return;
}
}
#..........................................................................
sub formatter_sanity_check {
my $self = shift;
my $formatter_class = $self->{'formatter_class'}
|| $self->die( "NO FORMATTER CLASS YET!?" );
if(!$self->opt_T # so -T can FORCE sending to STDOUT
and $formatter_class->can('is_pageable')
and !$formatter_class->is_pageable
and !$formatter_class->can('page_for_perldoc')
) {
my $ext =
($formatter_class->can('output_extension')
&& $formatter_class->output_extension
) || '';
$ext = ".$ext" if length $ext;
my $me = $self->program_name;
$self->die(
"When using Perldoc to format with $formatter_class, you have to\n"
. "specify -T or -dsomefile$ext\n"
. "See `$me perldoc' for more information on those switches.\n" )
;
}
}
#..........................................................................
sub render_and_page {
my($self, $found_list) = @_;
$self->maybe_generate_dynamic_pod($found_list);
my($out, $formatter) = $self->render_findings($found_list);
if($self->opt_d) {
printf "Perldoc (%s) output saved to %s\n",
$self->{'formatter_class'} || ref($self),
$out;
print "But notice that it's 0 bytes long!\n" unless -s $out;
} elsif( # Allow the formatter to "page" itself, if it wants.
$formatter->can('page_for_perldoc')
and do {
$self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
if( $formatter->page_for_perldoc($out, $self) ) {
$self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
1;
} else {
$self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
'';
}
}
) {
# Do nothing, since the formatter has "paged" it for itself.
} else {
# Page it normally (internally)
if( -s $out ) { # Usual case:
$self->page($out, $self->{'output_to_stdout'}, $self->pagers);
} else {
# Odd case:
$self->aside("Skipping $out (from $$found_list[0] "
. "via $$self{'formatter_class'}) as it is 0-length.\n");
push @{ $self->{'temp_file_list'} }, $out;
$self->unlink_if_temp_file($out);
}
}
$self->after_rendering(); # any extra cleanup or whatever
return;
}
#..........................................................................
sub options_reading {
my $self = shift;
if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
require Text::ParseWords;
$self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
# Yes, appends to the beginning
unshift @{ $self->{'args'} },
Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
;
DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
} else {
DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
}
DEBUG > 1
and print " Args right before switch processing: @{$self->{'args'}}\n";
Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
or return $self->usage;
DEBUG > 1
and print " Args after switch processing: @{$self->{'args'}}\n";
return $self->usage if $self->opt_h;
return;
}
#..........................................................................
sub options_processing {
my $self = shift;
if ($self->opt_X) {
my $podidx = "$Config{'archlib'}/pod.idx";
$podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
$self->{'podidx'} = $podidx;
}
$self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
$self->options_sanity;
# This used to set a default, but that's now moved into any
# formatter that cares to have a default.
if( $self->opt_n ) {
$self->add_formatter_option( '__nroffer' => $self->opt_n );
}
# Get language from PERLDOC_POD2 environment variable
if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) {
if ( $ENV{PERLDOC_POD2} eq '1' ) {
$self->_elem('opt_L',(split(/\_/, $ENV{LC_ALL} || $ENV{LC_LANG} || $ENV{LANG}))[0] );
}
else {
$self->_elem('opt_L', $ENV{PERLDOC_POD2});
}
};
# Adjust for using translation packages
$self->add_translator(split(/\s+/,$self->opt_L)) if $self->opt_L;
return;
}
#..........................................................................
sub options_sanity {
my $self = shift;
# The opts-counting stuff interacts quite badly with
# the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
# set to -t, and I specify -u on the command line, I don't want
# to be hectored at that -u and -t don't make sense together.
#my $opts = grep $_ && 1, # yes, the count of the set ones
# $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
#;
#
#$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
# Any sanity-checking need doing here?
# But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
if( $self->opt_f or $self->opt_q or $self->opt_a) {
my $count;
$count++ if $self->opt_f;
$count++ if $self->opt_q;
$count++ if $self->opt_a;
$self->usage("Only one of -f or -q or -a") if $count > 1;
$self->warn(
"Perldoc is meant for reading one file at a time.\n",
"So these parameters are being ignored: ",
join(' ', @{$self->{'args'}}),
"\n" )
if @{$self->{'args'}}
}
return;
}
#..........................................................................
sub grand_search_init {
my($self, $pages, @found) = @_;
foreach (@$pages) {
if (/^http(s)?:\/\//) {
require HTTP::Tiny;
require File::Temp;
my $response = HTTP::Tiny->new->get($_);
if ($response->{success}) {
my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
$fh->print($response->{content});
push @found, $filename;
($self->{podnames}{$filename} =
m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN")
=~ s/\.P(?:[ML]|OD)\z//;
}
else {
print STDERR "No " .
($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
if ( /^https/ ) {
print STDERR "You may need an SSL library (such as IO::Socket::SSL) for that URL.\n";
}
}
next;
}
if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
my $searchfor = catfile split '::', $_;
$self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
local $_;
while (<PODIDX>) {
chomp;
push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
}
close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" );
next;
}
$self->aside( "Searching for $_\n" );
if ($self->opt_F) {
next unless -r;
push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_);
next;
}
my @searchdirs;
# prepend extra search directories (including language specific)
push @searchdirs, @{ $self->{'extra_search_dirs'} };
# We must look both in @INC for library modules and in $bindir
# for executables, like h2xs or perldoc itself.
push @searchdirs, ($self->{'bindir'}, @{$self->{search_path}}, @INC);
unless ($self->opt_m) {
if ($self->is_vms) {
my($i,$trn);
for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
push(@searchdirs,$trn);
}
push(@searchdirs,'perl_root:[lib.pods]') # installed pods
}
else {
push(@searchdirs, grep(-d, split($Config{path_sep},
$ENV{'PATH'})));
}
}
my @files = $self->searchfor(0,$_,@searchdirs);
if (@files) {
$self->aside( "Found as @files\n" );
}
# add "perl" prefix, so "perldoc foo" may find perlfoo.pod
elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
$self->aside( "Loosely found as @files\n" );
}
else {
# no match, try recursive search
@searchdirs = grep(!/^\.\z/s,@INC);
@files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
if (@files) {
$self->aside( "Loosely found as @files\n" );
}
else {
print STDERR "No " .
($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
if ( @{ $self->{'found'} } ) {
print STDERR "However, try\n";
my $me = $self->program_name;
for my $dir (@{ $self->{'found'} }) {
opendir(DIR, $dir) or $self->die( "opendir $dir: $!" );
while (my $file = readdir(DIR)) {
next if ($file =~ /^\./s);
$file =~ s/\.(pm|pod)\z//; # XXX: badfs
print STDERR "\t$me $_\::$file\n";
}
closedir(DIR) or $self->die( "closedir $dir: $!" );
}
}
}
}
push(@found,@files);
}
return @found;
}
#..........................................................................
sub maybe_generate_dynamic_pod {
my($self, $found_things) = @_;
my @dynamic_pod;
$self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a;
$self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
$self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
$self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) {
DEBUG > 4 and print "That's a non-dynamic pod search.\n";
} elsif ( @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, ":encoding(UTF-8)");
print $buffd "=encoding utf8\n\n";
}
push @{ $self->{'temp_file_list'} }, $buffer;
# I.e., it MIGHT be deleted at the end.
my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a;
print $buffd "=over 8\n\n" if $in_list;
print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" );
print $buffd "=back\n" if $in_list;
close $buffd or $self->die( "Can't close $buffer: $!" );
@$found_things = $buffer;
# Yes, so found_things never has more than one thing in
# it, by time we leave here
$self->add_formatter_option('__filter_nroff' => 1);
} else {
@$found_things = ();
$self->aside("I found no Pod from that search!\n");
}
return;
}
#..........................................................................
sub not_dynamic {
my ($self,$value) = @_;
$self->{__not_dynamic} = $value if @_ == 2;
return $self->{__not_dynamic};
}
#..........................................................................
sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
my $self = shift;
push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
return;
}
#.........................................................................
sub new_translator { # $tr = $self->new_translator($lang);
my $self = shift;
my $lang = shift;
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
my $pack = 'POD2::' . uc($lang);
eval "require $pack";
if ( !$@ && $pack->can('new') ) {
return $pack->new();
}
eval { require POD2::Base };
return if $@;
return POD2::Base->new({ lang => $lang });
}
#.........................................................................
sub add_translator { # $self->add_translator($lang);
my $self = shift;
for my $lang (@_) {
my $tr = $self->new_translator($lang);
if ( defined $tr ) {
push @{ $self->{'translators'} }, $tr;
push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
$self->aside( "translator for '$lang' loaded\n" );
} else {
# non-installed or bad translator package
$self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" );
}
}
return;
}
#..........................................................................
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) = @_;
my $opt = $self->opt_v;
if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
CORE::die( "'$opt' does not look like a Perl variable\n" );
}
DEBUG > 2 and print "Search: @$found_things\n";
my $perlvar = shift @$found_things;
my $fh = $self->open_fh("<", $perlvar);
if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
$opt = '$<I<digits>>';
}
my $search_re = quotemeta($opt);
DEBUG > 2 and
print "Going to perlvar-scan for $search_re in $perlvar\n";
# Skip introduction
local $_;
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 (<$fh>) {
last if /^=head2 Error Indicators/;
# \b at the end of $` and friends borks things!
if ( m/^=item\s+$search_re\s/ ) {
$found = 1;
}
elsif (/^=item/) {
last if $found && !$inheader && !$inlist;
}
elsif (!/^\s+$/) { # not a blank line
if ( $found ) {
$inheader = 0; # don't accept more =item (unless inlist)
}
else {
@$pod = (); # reset
$inheader = 1; # start over
next;
}
}
if (/^=over/) {
++$inlist;
}
elsif (/^=back/) {
last if $found && !$inheader && !$inlist;
--$inlist;
}
push @$pod, $_;
# ++$found if /^\w/; # found descriptive text
}
@$pod = () unless $found;
if (!@$pod) {
CORE::die( "No documentation for perl variable '$opt' found\n" );
}
close $fh or $self->die( "Can't close $perlvar: $!" );
return;
}
#..........................................................................
sub search_perlop {
my ($self,$found_things,$pod) = @_;
$self->not_dynamic( 1 );
my $perlop = shift @$found_things;
# 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]
my $fh = $self->open_fh('<', $perlop);
my $thing = $self->opt_f;
my $previous_line;
my $push = 0;
my $seen_item = 0;
my $skip = 1;
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;
}
next if $skip;
# strategy is to capture the previous line until we get a match on X<$thingy>
# if the current line contains X<$thingy>, then we push "=over", the previous line,
# the current line and keep pushing current line until we see a ^X<some-other-thing>,
# then we chop off final line from @$pod and add =back
#
# At that point, Bob's your uncle.
if ( $line =~ m!X<+\s*\Q$thing\E\s*>+!) {
if ( $previous_line ) {
push @$pod, "=over 8\n\n", $previous_line;
$previous_line = "";
}
push @$pod, $line;
$push = 1;
}
elsif ( $push and $line =~ m!^=item\s*.*$! ) {
$seen_item = 1;
}
elsif ( $push and $seen_item and $line =~ m!^X<+\s*[ a-z,?-]+\s*>+!) {
$push = 0;
$seen_item = 0;
last;
}
elsif ( $push ) {
push @$pod, $line;
}
else {
$previous_line = $line;
}
} #end while
# we overfilled by 1 line, so pop off final array element if we have any
if ( scalar @$pod ) {
pop @$pod;
# and add the =back
push @$pod, "\n\n=back\n";
DEBUG > 8 and print "PERLOP POD --->" . (join "", @$pod) . "<---\n";
}
else {
DEBUG > 4 and print "No pod from perlop\n";
}
close $fh;
return;
}
#..........................................................................
sub search_perlapi {
my($self, $found_things, $pod) = @_;
DEBUG > 2 and print "Search: @$found_things\n";
my $perlapi = shift @$found_things;
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";
local $_;
# Look for our function
my $found = 0;
my $inlist = 0;
my @related;
my $related_re;
while (<$fh>) {
/^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
if ( m/^=item\s+$search_re\b/ ) {
$found = 1;
}
elsif (@related > 1 and /^=item/) {
$related_re ||= join "|", @related;
if (m/^=item\s+(?:$related_re)\b/) {
$found = 1;
}
else {
last;
}
}
elsif (/^=item/) {
last if $found > 1 and not $inlist;
}
elsif ($found and /^X<[^>]+>/) {
push @related, m/X<([^>]+)>/g;
}
next unless $found;
if (/^=over/) {
++$inlist;
}
elsif (/^=back/) {
last if $found > 1 and not $inlist;
--$inlist;
}
push @$pod, $_;
++$found if /^\w/; # found descriptive text
}
if (!@$pod) {
CORE::die( sprintf
"No documentation for perl api function '%s' found\n",
$self->opt_a )
;
}
close $fh or $self->die( "Can't open $perlapi: $!" );
return;
}
#..........................................................................
sub search_perlfunc {
my($self, $found_things, $pod) = @_;
DEBUG > 2 and print "Search: @$found_things\n";
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 $pfunc\n";
my $re = 'Alphabetical Listing of Perl Functions';
# Check available translator or backup to default (english)
if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
my $tr = $self->{'translators'}->[0];
$re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
if ( $] < 5.008 ) {
$self->aside("Your old perl doesn't really have proper unicode support.");
}
}
# Skip introduction
local $_;
while (<$fh>) {
/^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
last if /^=head2 (?:$re|Alphabetical Listing of Perl Functions)/;
}
# Look for our function
my $found = 0;
my $inlist = 0;
my @perlops = qw(m q qq qr qx qw s tr y);
my @related;
my $related_re;
while (<$fh>) { # "The Mothership Connection is here!"
last if( grep{ $self->opt_f eq $_ }@perlops );
if ( /^=over/ and not $found ) {
++$inlist;
}
elsif ( /^=back/ and not $found and $inlist ) {
--$inlist;
}
if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) {
$found = 1;
}
elsif (@related > 1 and /^=item/) {
$related_re ||= join "|", @related;
if (m/^=item\s+(?:$related_re)\b/) {
$found = 1;
}
else {
last if $found > 1 and $inlist < 2;
}
}
elsif (/^=item|^=back/) {
last if $found > 1 and $inlist < 2;
}
elsif ($found and /^X<[^>]+>/) {
push @related, m/X<([^>]+)>/g;
}
next unless $found;
if (/^=over/) {
++$inlist;
}
elsif (/^=back/) {
--$inlist;
}
push @$pod, $_;
++$found if /^\w/; # found descriptive text
}
if( !@$pod ){
$self->search_perlop( $found_things, $pod );
}
if (!@$pod) {
CORE::die( sprintf
"No documentation for perl function '%s' found\n",
$self->opt_f )
;
}
close $fh or $self->die( "Can't close $pfunc: $!" );
return;
}
#..........................................................................
sub search_perlfaqs {
my( $self, $found_things, $pod) = @_;
my $found = 0;
my %found_in;
my $search_key = $self->opt_q;
my $rx = eval { qr/$search_key/ }
or $self->die( <<EOD );
Invalid regular expression '$search_key' given as -q pattern:
$@
Did you mean \\Q$search_key ?
EOD
local $_;
foreach my $file (@$found_things) {
$self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
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}++;
}
elsif (/^=head[12]/) {
$found = 0;
}
next unless $found;
push @$pod, $_;
}
close($fh);
}
CORE::die("No documentation for perl FAQ keyword '$search_key' found\n")
unless @$pod;
if ( $self->opt_l ) {
CORE::die((join "\n", keys %found_in) . "\n");
}
return;
}
#..........................................................................
sub render_findings {
# Return the filename to open
my($self, $found_things) = @_;
my $formatter_class = $self->{'formatter_class'}
|| $self->die( "No formatter class set!?" );
my $formatter = $formatter_class->can('new')
? $formatter_class->new
: $formatter_class
;
if(! @$found_things) {
$self->die( "Nothing found?!" );
# should have been caught before here
} elsif(@$found_things > 1) {
$self->warn(
"Perldoc is only really meant for reading one document at a time.\n",
"So these parameters are being ignored: ",
join(' ', @$found_things[1 .. $#$found_things] ),
"\n" );
}
my $file = $found_things->[0];
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
# Set formatter options:
if( ref $formatter ) {
foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
my($switch, $value, $silent_fail) = @$f;
if( $formatter->can($switch) ) {
eval { $formatter->$switch( defined($value) ? $value : () ) };
$self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" )
if $@;
} else {
if( $silent_fail or $switch =~ m/^__/s ) {
DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
} else {
$self->warn( "$formatter_class doesn't recognize the $switch switch.\n" );
}
}
}
}
$self->{'output_is_binary'} =
$formatter->can('write_with_binmode') && $formatter->write_with_binmode;
if( $self->{podnames} and exists $self->{podnames}{$file} and
$formatter->can('name') ) {
$formatter->name($self->{podnames}{$file});
}
my ($out_fh, $out) = $self->new_output_file(
( $formatter->can('output_extension') && $formatter->output_extension )
|| undef,
$self->useful_filename_bit,
);
# Now, finally, do the formatting!
{
local $^W = $^W;
if(DEBUG() or $self->opt_D) {
# feh, let 'em see it
} else {
$^W = 0;
# The average user just has no reason to be seeing
# $^W-suppressible warnings from the formatting!
}
eval { $formatter->parse_from_file( $file, $out_fh ) };
}
$self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@;
DEBUG > 2 and print "Back from formatting with $formatter_class\n";
close $out_fh
or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" );
sleep 0; sleep 0; sleep 0;
# Give the system a few timeslices to meditate on the fact
# that the output file does in fact exist and is closed.
$self->unlink_if_temp_file($file);
unless( -s $out ) {
if( $formatter->can( 'if_zero_length' ) ) {
# Basically this is just a hook for Pod::Simple::Checker; since
# what other class could /happily/ format an input file with Pod
# as a 0-length output file?
$formatter->if_zero_length( $file, $out, $out_fh );
} else {
$self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" );
}
}
DEBUG and print "Finished writing to $out.\n";
return($out, $formatter) if wantarray;
return $out;
}
#..........................................................................
sub unlink_if_temp_file {
# Unlink the specified file IFF it's in the list of temp files.
# Really only used in the case of -f / -q things when we can
# throw away the dynamically generated source pod file once
# we've formatted it.
#
my($self, $file) = @_;
return unless defined $file and length $file;
my $temp_file_list = $self->{'temp_file_list'} || return;
if(grep $_ eq $file, @$temp_file_list) {
$self->aside("Unlinking $file\n");
unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" );
} else {
DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
}
return;
}
#..........................................................................
sub after_rendering {
my $self = $_[0];
$self->after_rendering_VMS if $self->is_vms;
$self->after_rendering_MSWin32 if $self->is_mswin32;
$self->after_rendering_Dos if $self->is_dos;
$self->after_rendering_OS2 if $self->is_os2;
return;
}
sub after_rendering_VMS { return }
sub after_rendering_Dos { return }
sub after_rendering_OS2 { return }
sub after_rendering_MSWin32 { return }
#..........................................................................
# : : : : : : : : :
#..........................................................................
sub minus_f_nocase { # i.e., do like -f, but without regard to case
my($self, $dir, $file) = @_;
my $path = catfile($dir,$file);
return $path if -f $path and -r _;
if(!$self->opt_i
or $self->is_vms or $self->is_mswin32
or $self->is_dos or $self->is_os2
) {
# On a case-forgiving file system, or if case is important,
# that is it, all we can do.
$self->warn( "Ignored $path: unreadable\n" ) if -f _;
return '';
}
local *DIR;
my @p = ($dir);
my($p,$cip);
foreach $p (splitdir $file){
my $try = catfile @p, $p;
$self->aside("Scrutinizing $try...\n");
stat $try;
if (-d _) {
push @p, $p;
if ( $p eq $self->{'target'} ) {
my $tmp_path = catfile @p;
my $path_f = 0;
for (@{ $self->{'found'} }) {
$path_f = 1 if $_ eq $tmp_path;
}
push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
$self->aside( "Found as $tmp_path but directory\n" );
}
}
elsif (-f _ && -r _ && lc($try) eq lc($path)) {
return $try;
}
elsif (-f _) {
$self->warn( "Ignored $try: unreadable or file/dir mismatch\n" );
}
elsif (-d catdir(@p)) { # at least we see the containing directory!
my $found = 0;
my $lcp = lc $p;
my $p_dirspec = catdir(@p);
opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" );
while(defined( $cip = readdir(DIR) )) {
if (lc $cip eq $lcp){
$found++;
last; # XXX stop at the first? what if there's others?
}
}
closedir DIR or $self->die( "closedir $p_dirspec: $!" );
return "" unless $found;
push @p, $cip;
my $p_filespec = catfile(@p);
return $p_filespec if -f $p_filespec and -r _;
$self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _;
}
}
return "";
}
#..........................................................................
sub pagers_guessing {
# TODO: This whole subroutine needs to be rewritten. It's semi-insane
# right now.
my $self = shift;
my @pagers;
push @pagers, $self->pagers;
$self->{'pagers'} = \@pagers;
if ($self->is_mswin32) {
push @pagers, qw( more< less notepad );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
elsif ($self->is_vms) {
push @pagers, qw( most more less type/page );
}
elsif ($self->is_dos) {
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 <';
}
push @pagers, qw( more less pg view cat );
unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER};
}
if ($self->is_cygwin) {
if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
unshift @pagers, '/usr/bin/less -isrR';
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
}
if ( $self->opt_m ) {
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};
}
$self->aside("Pagers: ", (join ", ", @pagers));
return;
}
#..........................................................................
sub page_module_file {
my($self, @found) = @_;
# Security note:
# Don't ever just pass this off to anything like MSWin's "start.exe",
# since we might be calling on a .pl file, and we wouldn't want that
# to actually /execute/ the file that we just want to page thru!
# Also a consideration if one were to use a web browser as a pager;
# doing so could trigger the browser's MIME mapping for whatever
# it thinks .pm/.pl/whatever is. Probably just a (useless and
# annoying) "Save as..." dialog, but potentially executing the file
# in question -- particularly in the case of MSIE and it's, ahem,
# occasionally hazy distinction between OS-local extension
# associations, and browser-specific MIME mappings.
if(@found > 1) {
$self->warn(
"Perldoc is only really meant for reading one document at a time.\n" .
"So these files are being ignored: " .
join(' ', @found[1 .. $#found] ) .
"\n" )
}
return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers);
}
#..........................................................................
sub check_file {
my($self, $dir, $file) = @_;
unless( ref $self ) {
# Should never get called:
$Carp::Verbose = 1;
require Carp;
Carp::croak( join '',
"Crazy ", __PACKAGE__, " error:\n",
"check_file must be an object_method!\n",
"Aborting"
);
}
if(length $dir and not -d $dir) {
DEBUG > 3 and print " No dir $dir -- skipping.\n";
return "";
}
my $path = $self->minus_f_nocase($dir,$file);
if( length $path and ($self->opt_m ? $self->isprintable($path)
: $self->containspod($path)) ) {
DEBUG > 3 and print
" The file $path indeed looks promising!\n";
return $path;
}
DEBUG > 3 and print " No good: $file in $dir\n";
return "";
}
sub isprintable {
my($self, $file, $readit) = @_;
my $size= 1024;
my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc.
return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i;
my $data;
local($_);
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;
}
#..........................................................................
sub containspod {
my($self, $file, $readit) = @_;
return 1 if !$readit && $file =~ /\.pod\z/i;
# Under cygwin the /usr/bin/perl is legal executable, but
# you cannot open a file with that name. It must be spelled
# out as "/usr/bin/perl.exe".
#
# The following if-case under cygwin prevents error
#
# $ perldoc perl
# Cannot open /usr/bin/perl: no such file or directory
#
# This would work though
#
# $ perldoc perl.pod
if ( $self->is_cygwin and -x $file and -f "$file.exe" )
{
$self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D;
return 0;
}
local($_);
my $fh = $self->open_fh("<", $file);
while (<$fh>) {
if (/^=head/) {
close($fh) or $self->die( "Can't close $file: $!" );
return 1;
}
}
close($fh) or $self->die( "Can't close $file: $!" );
return 0;
}
#..........................................................................
sub maybe_extend_searchpath {
my $self = shift;
# Does this look like a module or extension directory?
if (-f "Makefile.PL" || -f "Build.PL") {
push @{$self->{search_path} }, '.','lib';
# don't add if superuser
if ($< && $> && -d "blib") { # don't be looking too hard now!
push @{ $self->{search_path} }, 'blib';
$self->warn( $@ ) if $@ && $self->opt_D;
}
}
return;
}
#..........................................................................
sub new_output_file {
my $self = shift;
my $outspec = $self->opt_d; # Yes, -d overrides all else!
# So don't call this twice per format-job!
return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
# Otherwise open a write-handle on opt_d!f
DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
my $fh = $self->open_fh(">", $outspec);
DEBUG > 3 and print "Successfully opened $outspec\n";
binmode($fh) if $self->{'output_is_binary'};
return($fh, $outspec);
}
#..........................................................................
sub useful_filename_bit {
# This tries to provide a meaningful bit of text to do with the query,
# such as can be used in naming the file -- since if we're going to be
# opening windows on temp files (as a "pager" may well do!) then it's
# better if the temp file's name (which may well be used as the window
# title) isn't ALL just random garbage!
# In other words "perldoc_LWPSimple_2371981429" is a better temp file
# name than "perldoc_2371981429". So this routine is what tries to
# provide the "LWPSimple" bit.
#
my $self = shift;
my $pages = $self->{'pages'} || return undef;
return undef unless @$pages;
my $chunk = $pages->[0];
return undef unless defined $chunk;
$chunk =~ s/:://g;
$chunk =~ s/\.\w+$//g; # strip any extension
if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
$chunk = $1;
} else {
return undef;
}
$chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
$chunk = substr($chunk, -10) if length($chunk) > 10;
return $chunk;
}
#..........................................................................
sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
my $self = shift;
++$Temp_Files_Created;
require File::Temp;
return File::Temp::tempfile(UNLINK => 1);
}
#..........................................................................
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");
my $fh = $self->open_fh("<", $output);
local $_;
while (<$fh>) {
print or $self->die( "Can't print to stdout: $!" );
}
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
# extension get the wrong default extension (such as .LIS for TYPE)
$output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms;
$output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos;
# Altho "/" under MSWin is in theory good as a pathsep,
# 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 {
my $formatter = $self->{'formatter_class'};
if ( $formatter->can('pager_configuration') ) {
$self->aside("About to call $formatter" . "->pager_configuration(\"$pager\")\n");
$formatter->pager_configuration($pager, $self);
}
last if system("$pager \"$output\"") == 0;
}
}
}
return;
}
#..........................................................................
sub searchfor {
my($self, $recurse,$s,@dirs) = @_;
$s =~ s!::!/!g;
$s = VMS::Filespec::unixify($s) if $self->is_vms;
return $s if -f $s && $self->containspod($s);
$self->aside( "Looking for $s in @dirs\n" );
my $ret;
my $i;
my $dir;
$self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
for ($i=0; $i<@dirs; $i++) {
$dir = $dirs[$i];
next unless -d $dir;
($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms;
if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
or ( $ret = $self->check_file($dir,"$s.pm"))
or ( $ret = $self->check_file($dir,$s))
or ( $self->is_vms and
$ret = $self->check_file($dir,"$s.com"))
or ( $self->is_os2 and
$ret = $self->check_file($dir,"$s.cmd"))
or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and
$ret = $self->check_file($dir,"$s.bat"))
or ( $ret = $self->check_file("$dir/pod","$s.pod"))
or ( $ret = $self->check_file("$dir/pod",$s))
or ( $ret = $self->check_file("$dir/pods","$s.pod"))
or ( $ret = $self->check_file("$dir/pods",$s))
) {
DEBUG > 1 and print " Found $ret\n";
return $ret;
}
if ($recurse) {
opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" );
my @newdirs = map catfile($dir, $_), grep {
not /^\.\.?\z/s and
not /^auto\z/s and # save time! don't search auto dirs
-d catfile($dir, $_)
} readdir D;
closedir(D) or $self->die( "Can't closedir $dir: $!" );
next unless @newdirs;
# what a wicked map!
@newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms;
$self->aside( "Also looking in @newdirs\n" );
push(@dirs,@newdirs);
}
}
return ();
}
#..........................................................................
{
my $already_asserted;
sub assert_closing_stdout {
my $self = shift;
return if $already_asserted;
eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~;
# What for? to let the pager know that nothing more will come?
$self->die( $@ ) if $@;
$already_asserted = 1;
return;
}
}
#..........................................................................
sub tweak_found_pathnames {
my($self, $found) = @_;
if ($self->is_mswin32) {
foreach (@$found) { s,/,\\,g }
}
foreach (@$found) { s,',\\',g } # RT 37347
return;
}
#..........................................................................
# : : : : : : : : :
#..........................................................................
sub am_taint_checking {
my $self = shift;
$self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way
my($k,$v) = each %ENV;
return is_tainted($v);
}
#..........................................................................
sub is_tainted { # just a function
my $arg = shift;
my $nada = substr($arg, 0, 0); # zero-length!
local $@; # preserve the caller's version of $@
eval { eval "# $nada" };
return length($@) != 0;
}
#..........................................................................
sub drop_privs_maybe {
my $self = shift;
DEBUG and print "Attempting to drop privs...\n";
# Attempt to drop privs if we should be tainting and aren't
if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos
|| $self->is_os2
)
&& ($> == 0 || $< == 0)
&& !$self->am_taint_checking()
) {
my $id = eval { getpwnam("nobody") };
$id = eval { getpwnam("nouser") } unless defined $id;
$id = -2 unless defined $id;
#
# According to Stevens' APUE and various
# (BSD, Solaris, HP-UX) man pages, setting
# the real uid first and effective uid second
# is the way to go if one wants to drop privileges,
# because if one changes into an effective uid of
# non-zero, one cannot change the real uid any more.
#
# Actually, it gets even messier. There is
# a third uid, called the saved uid, and as
# long as that is zero, one can get back to
# uid of zero. Setting the real-effective *twice*
# helps in *most* systems (FreeBSD and Solaris)
# but apparently in HP-UX even this doesn't help:
# the saved uid stays zero (apparently the only way
# in HP-UX to change saved uid is to call setuid()
# when the effective uid is zero).
#
eval {
$< = $id; # real uid
$> = $id; # effective uid
$< = $id; # real uid
$> = $id; # effective uid
};
if( !$@ && $< && $> ) {
DEBUG and print "OK, I dropped privileges.\n";
} elsif( $self->opt_U ) {
DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
} else {
DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
# We used to die here; but that seemed pointless.
}
}
return;
}
#..........................................................................
1;
__END__
=head1 NAME
Pod::Perldoc - Look up Perl documentation in Pod format.
=head1 SYNOPSIS
use Pod::Perldoc ();
Pod::Perldoc->run();
=head1 DESCRIPTION
The guts of L<perldoc> utility.
=head1 SEE ALSO
L<perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2002-2007 Sean M. Burke.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=head1 AUTHOR
Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
brian d foy C<< <bdfoy@cpan.org> >>
Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
Sean M. Burke C<< <sburke@cpan.org> >>
=cut
Mini Shell