1N/A

1N/Arequire 5;

1N/Ause 5.006; # we use some open(X, "<", $y) syntax

1N/Apackage Pod::Perldoc;

1N/Ause strict;

1N/Ause warnings;

1N/Ause Config '%Config';

1N/A

1N/Ause Fcntl; # for sysopen

1N/Ause File::Spec::Functions qw(catfile catdir splitdir);

1N/A

1N/Ause vars qw($VERSION @Pagers $Bindir $Pod2man

1N/A $Temp_Files_Created $Temp_File_Lifetime

1N/A);

1N/A$VERSION = '3.12';

1N/A

1N/ABEGIN { # Make a DEBUG constant very first thing...

1N/A unless(defined &DEBUG) {

1N/A if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint

1N/A eval("sub DEBUG () {$1}");

1N/A die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;

1N/A } else {

1N/A *DEBUG = sub () {0};

1N/A }

1N/A }

1N/A}

1N/A

1N/Ause Pod::Perldoc::GetOptsOO; # uses the DEBUG.

1N/A

1N/A

1N/Asub TRUE () {1}

1N/Asub FALSE () {return}

1N/A

1N/ABEGIN {

1N/A *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;

1N/A *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;

1N/A *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;

1N/A *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;

1N/A *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;

1N/A *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;

1N/A *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;

1N/A}

1N/A

1N/A$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;

1N/A # If it's older than five days, it's quite unlikely

1N/A # that anyone's still looking at it!!

1N/A # (Currently used only by the MSWin cleanup routine)

1N/A

1N/A

1N/A{ my $pager = $Config{'pager'};

1N/A push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;

1N/A}

1N/A$Bindir = $Config{'scriptdirexp'};

1N/A$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );

1N/A

1N/A

1N/Aforeach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) {

1N/A no strict 'refs';

1N/A *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };

1N/A}

1N/A

1N/Asub opt_f_with { shift->_elem('opt_f', @_) }

1N/Asub opt_q_with { shift->_elem('opt_q', @_) }

1N/Asub opt_d_with { shift->_elem('opt_d', @_) }

1N/A

1N/Asub opt_w_with { # Specify an option for the formatter subclass

1N/A my($self, $value) = @_;

1N/A if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {

1N/A my $option = $1;

1N/A my $option_value = defined($2) ? $2 : "TRUE";

1N/A $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"

1N/A $self->add_formatter_option( $option, $option_value );

1N/A } else {

1N/A warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";

1N/A }

1N/A return;

1N/A}

1N/A

1N/Asub opt_M_with { # specify formatter class name(s)

1N/A my($self, $classes) = @_;

1N/A return unless defined $classes and length $classes;

1N/A DEBUG > 4 and print "Considering new formatter classes -M$classes\n";

1N/A my @classes_to_add;

1N/A foreach my $classname (split m/[,;]+/s, $classes) {

1N/A next unless $classname =~ m/\S/;

1N/A if( $classname =~ m/^(\w+(::\w+)+)$/s ) {

1N/A # A mildly restrictive concept of what modulenames are valid.

1N/A push @classes_to_add, $1; # untaint

1N/A } else {

1N/A warn "\"$classname\" isn't a valid classname. Ignoring.\n";

1N/A }

1N/A }

1N/A

1N/A unshift @{ $self->{'formatter_classes'} }, @classes_to_add;

1N/A

1N/A DEBUG > 3 and print(

1N/A "Adding @classes_to_add to the list of formatter classes, "

1N/A . "making them @{ $self->{'formatter_classes'} }.\n"

1N/A );

1N/A

1N/A return;

1N/A}

1N/A

1N/Asub opt_V { # report version and exit

1N/A print join '',

1N/A "Perldoc v$VERSION, under perl v$] for $^O",

1N/A

1N/A (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())

1N/A ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),

1N/A

1N/A (chr(65) eq 'A') ? () : " (non-ASCII)",

1N/A

1N/A "\n",

1N/A ;

1N/A exit;

1N/A}

1N/A

1N/Asub opt_t { # choose plaintext as output format

1N/A my $self = shift;

1N/A $self->opt_o_with('text') if @_ and $_[0];

1N/A return $self->_elem('opt_t', @_);

1N/A}

1N/A

1N/Asub opt_u { # choose raw pod as output format

1N/A my $self = shift;

1N/A $self->opt_o_with('pod') if @_ and $_[0];

1N/A return $self->_elem('opt_u', @_);

1N/A}

1N/A

1N/Asub opt_n_with {

1N/A # choose man as the output format, and specify the proggy to run

1N/A my $self = shift;

1N/A $self->opt_o_with('man') if @_ and $_[0];

1N/A $self->_elem('opt_n', @_);

1N/A}

1N/A

1N/Asub opt_o_with { # "o" for output format

1N/A my($self, $rest) = @_;

1N/A return unless defined $rest and length $rest;

1N/A if($rest =~ m/^(\w+)$/s) {

1N/A $rest = $1; #untaint

1N/A } else {

1N/A warn "\"$rest\" isn't a valid output format. Skipping.\n";

1N/A return;

1N/A }

1N/A

1N/A $self->aside("Noting \"$rest\" as desired output format...\n");

1N/A

1N/A # Figure out what class(es) that could actually mean...

1N/A

1N/A my @classes;

1N/A foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {

1N/A # Messy but smart:

1N/A foreach my $stem (

1N/A $rest, # Yes, try it first with the given capitalization

1N/A "\L$rest", "\L\u$rest", "\U$rest" # And then try variations

1N/A

1N/A ) {

1N/A push @classes, $prefix . $stem;

1N/A #print "Considering $prefix$stem\n";

1N/A }

1N/A

1N/A # Tidier, but misses too much:

1N/A #push @classes, $prefix . ucfirst(lc($rest));

1N/A }

1N/A $self->opt_M_with( join ";", @classes );

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub run { # to be called by the "perldoc" executable

1N/A my $class = shift;

1N/A if(DEBUG > 3) {

1N/A print "Parameters to $class\->run:\n";

1N/A my @x = @_;

1N/A while(@x) {

1N/A $x[1] = '<undef>' unless defined $x[1];

1N/A $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';

1N/A print " [$x[0]] => [$x[1]]\n";

1N/A splice @x,0,2;

1N/A }

1N/A print "\n";

1N/A }

1N/A return $class -> new(@_) -> process() || 0;

1N/A}

1N/A

1N/A

1N/Asub new { # yeah, nothing fancy

1N/A my $class = shift;

1N/A my $new = bless {@_}, (ref($class) || $class);

1N/A DEBUG > 1 and print "New $class object $new\n";

1N/A $new->init();

1N/A $new;

1N/A}

1N/A

1N/A

1N/Asub aside { # If we're in -v or DEBUG mode, say this.

1N/A my $self = shift;

1N/A if( DEBUG or $self->opt_v ) {

1N/A my $out = join( '',

1N/A DEBUG ? do {

1N/A my $callsub = (caller(1))[3];

1N/A my $package = quotemeta(__PACKAGE__ . '::');

1N/A $callsub =~ s/^$package/'/os;

1N/A # the o is justified, as $package really won't change.

1N/A $callsub . ": ";

1N/A } : '',

1N/A @_,

1N/A );

1N/A if(DEBUG) { print $out } else { print STDERR $out }

1N/A }

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub usage {

1N/A my $self = shift;

1N/A warn "@_\n" if @_;

1N/A

1N/A # Erase evidence of previous errors (if any), so exit status is simple.

1N/A $! = 0;

1N/A

1N/A die <<EOF;

1N/Aperldoc [options] PageName|ModuleName|ProgramName...

1N/Aperldoc [options] -f BuiltinFunction

1N/Aperldoc [options] -q FAQRegex

1N/A

1N/AOptions:

1N/A -h Display this help message

1N/A -V report version

1N/A -r Recursive search (slow)

1N/A -i Ignore case

1N/A -t Display pod using pod2text instead of pod2man and nroff

1N/A (-t is the default on win32 unless -n is specified)

1N/A -u Display unformatted pod text

1N/A -m Display module's file in its entirety

1N/A -n Specify replacement for nroff

1N/A -l Display the module's file name

1N/A -F Arguments are file names, not modules

1N/A -v Verbosely describe what's going on

1N/A -T Send output to STDOUT without any pager

1N/A -d output_filename_to_send_to

1N/A -o output_format_name

1N/A -M FormatterModuleNameToUse

1N/A -w formatter_option:option_value

1N/A -X use index if present (looks for pod.idx at $Config{archlib})

1N/A -q Search the text of questions (not answers) in perlfaq[1-9]

1N/A

1N/APageName|ModuleName...

1N/A is the name of a piece of documentation that you want to look at. You

1N/A may either give a descriptive name of the page (as in the case of

1N/A `perlfunc') the name of a module, either like `Term::Info' or like

1N/A `Term/Info', or the name of a program, like `perldoc'.

1N/A

1N/A is the name of a perl function. Will extract documentation from

1N/A `perlfunc'.

1N/A

1N/A is a regex. Will search perlfaq[1-9] for and extract any

1N/A questions that match.

1N/A

1N/AAny switches in the PERLDOC environment variable will be used before the

1N/Acommand line arguments. The optional pod index file contains a list of

1N/Afilenames, one per line.

1N/A [Perldoc v$VERSION]

1N/A

1N/A}

1N/A

1N/A

1N/Asub usage_brief {

1N/A my $me = $0; # Editing $0 is unportable

1N/A

1N/A $me =~ s,.*[/\\],,; # get basename

1N/A

1N/A die <<"EOUSAGE";

1N/AUsage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName

1N/A $me -f PerlFunc

1N/A $me -q FAQKeywords

1N/A

1N/AThe -h option prints more help. Also try "perldoc perldoc" to get

1N/Aacquainted with the system. [Perldoc v$VERSION]

1N/A

1N/A}

1N/A

1N/A

1N/Asub pagers { @{ shift->{'pagers'} } }

1N/A

1N/A

1N/Asub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)

1N/A if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }

1N/A else { return $_[0]{ $_[1] } }

1N/A}

1N/A

1N/Asub init {

1N/A my $self = shift;

1N/A

1N/A # Make sure creat()s are neither too much nor too little

1N/A eval { umask(0077) }; # doubtless someone has no mask

1N/A

1N/A $self->{'args'} ||= \@ARGV;

1N/A $self->{'found'} ||= [];

1N/A $self->{'temp_file_list'} ||= [];

1N/A

1N/A

1N/A $self->{'target'} = undef;

1N/A

1N/A $self->init_formatter_class_list;

1N/A

1N/A $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};

1N/A $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};

1N/A $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};

1N/A

1N/A push @{ $self->{'formatter_switches'} = [] }, (

1N/A # Yeah, we could use a hashref, but maybe there's some class where options

1N/A # have to be ordered; so we'll use an arrayref.

1N/A

1N/A [ '__bindir' => $self->{'bindir' } ],

1N/A [ '__pod2man' => $self->{'pod2man'} ],

1N/A );

1N/A

1N/A DEBUG > 3 and printf "Formatter switches now: [%s]\n",

1N/A join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub init_formatter_class_list {

1N/A my $self = shift;

1N/A $self->{'formatter_classes'} ||= [];

1N/A

1N/A # Remember, no switches have been read yet, when

1N/A # we've started this routine.

1N/A

1N/A $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru

1N/A $self->opt_o_with('text');

1N/A $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos

1N/A || !($ENV{TERM} && (

1N/A ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i

1N/A ));

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub process {

1N/A # if this ever returns, its retval will be used for exit(RETVAL)

1N/A

1N/A my $self = shift;

1N/A DEBUG > 1 and print " Beginning process.\n";

1N/A DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";

1N/A if(DEBUG > 3) {

1N/A print "Object contents:\n";

1N/A my @x = %$self;

1N/A while(@x) {

1N/A $x[1] = '<undef>' unless defined $x[1];

1N/A $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';

1N/A print " [$x[0]] => [$x[1]]\n";

1N/A splice @x,0,2;

1N/A }

1N/A print "\n";

1N/A }

1N/A

1N/A # TODO: make it deal with being invoked as various different things

1N/A # such as perlfaq".

1N/A

1N/A return $self->usage_brief unless @{ $self->{'args'} };

1N/A $self->pagers_guessing;

1N/A $self->options_reading;

1N/A $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);

1N/A $self->drop_privs_maybe;

1N/A $self->options_processing;

1N/A

1N/A # Hm, we have @pages and @found, but we only really act on one

1N/A # file per call, with the exception of the opt_q hack, and with

1N/A # -l things

1N/A

1N/A $self->aside("\n");

1N/A

1N/A my @pages;

1N/A $self->{'pages'} = \@pages;

1N/A if( $self->opt_f) { @pages = ("perlfunc") }

1N/A elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }

1N/A else { @pages = @{$self->{'args'}};

1N/A # @pages = __FILE__

1N/A # if @pages == 1 and $pages[0] eq 'perldoc';

1N/A }

1N/A

1N/A return $self->usage_brief unless @pages;

1N/A

1N/A $self->find_good_formatter_class();

1N/A $self->formatter_sanity_check();

1N/A

1N/A $self->maybe_diddle_INC();

1N/A # for when we're apparently in a module or extension directory

1N/A

1N/A my @found = $self->grand_search_init(\@pages);

1N/A exit (IS_VMS ? 98962 : 1) unless @found;

1N/A

1N/A if ($self->opt_l) {

1N/A DEBUG and print "We're in -l mode, so byebye after this:\n";

1N/A print join("\n", @found), "\n";

1N/A return;

1N/A }

1N/A

1N/A $self->tweak_found_pathnames(\@found);

1N/A $self->assert_closing_stdout;

1N/A return $self->page_module_file(@found) if $self->opt_m;

1N/A DEBUG > 2 and print "Found: [@found]\n";

1N/A

1N/A return $self->render_and_page(\@found);

1N/A}

1N/A

1N/A{

1N/A

1N/Amy( %class_seen, %class_loaded );

1N/Asub find_good_formatter_class {

1N/A my $self = $_[0];

1N/A my @class_list = @{ $self->{'formatter_classes'} || [] };

1N/A die "WHAT? Nothing in the formatter class list!?" unless @class_list;

1N/A

1N/A my $good_class_found;

1N/A foreach my $c (@class_list) {

1N/A DEBUG > 4 and print "Trying to load $c...\n";

1N/A if($class_loaded{$c}) {

1N/A DEBUG > 4 and print "OK, the already-loaded $c it is!\n";

1N/A $good_class_found = $c;

1N/A last;

1N/A }

1N/A

1N/A if($class_seen{$c}) {

1N/A DEBUG > 4 and print

1N/A "I've tried $c before, and it's no good. Skipping.\n";

1N/A next;

1N/A }

1N/A

1N/A $class_seen{$c} = 1;

1N/A

1N/A if( $c->can('parse_from_file') ) {

1N/A DEBUG > 4 and print

1N/A "Interesting, the formatter class $c is already loaded!\n";

1N/A

1N/A } elsif(

1N/A (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)

1N/A # the alway case-insensitive fs's

1N/A and $class_seen{lc("~$c")}++

1N/A ) {

1N/A DEBUG > 4 and print

1N/A "We already used something quite like \"\L$c\E\", so no point using $c\n";

1N/A # This avoids redefining the package.

1N/A } else {

1N/A DEBUG > 4 and print "Trying to eval 'require $c'...\n";

1N/A

1N/A local $^W = $^W;

1N/A if(DEBUG() or $self->opt_v) {

1N/A # feh, let 'em see it

1N/A } else {

1N/A $^W = 0;

1N/A # The average user just has no reason to be seeing

1N/A # $^W-suppressable warnings from the the require!

1N/A }

1N/A

1N/A eval "require $c";

1N/A if($@) {

1N/A DEBUG > 4 and print "Couldn't load $c: $!\n";

1N/A next;

1N/A }

1N/A }

1N/A

1N/A if( $c->can('parse_from_file') ) {

1N/A DEBUG > 4 and print "Settling on $c\n";

1N/A my $v = $c->VERSION;

1N/A $v = ( defined $v and length $v ) ? " version $v" : '';

1N/A $self->aside("Formatter class $c$v successfully loaded!\n");

1N/A $good_class_found = $c;

1N/A last;

1N/A } else {

1N/A DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";

1N/A }

1N/A }

1N/A

1N/A die "Can't find any loadable formatter class in @class_list?!\nAborting"

1N/A unless $good_class_found;

1N/A

1N/A $self->{'formatter_class'} = $good_class_found;

1N/A $self->aside("Will format with the class $good_class_found\n");

1N/A

1N/A return;

1N/A}

1N/A

1N/A}

1N/A

1N/Asub formatter_sanity_check {

1N/A my $self = shift;

1N/A my $formatter_class = $self->{'formatter_class'}

1N/A || die "NO FORMATTER CLASS YET!?";

1N/A

1N/A if(!$self->opt_T # so -T can FORCE sending to STDOUT

1N/A and $formatter_class->can('is_pageable')

1N/A and !$formatter_class->is_pageable

1N/A and !$formatter_class->can('page_for_perldoc')

1N/A ) {

1N/A my $ext =

1N/A ($formatter_class->can('output_extension')

1N/A && $formatter_class->output_extension

1N/A ) || '';

1N/A $ext = ".$ext" if length $ext;

1N/A

1N/A die

1N/A "When using Perldoc to format with $formatter_class, you have to\n"

1N/A . "specify -T or -dsomefile$ext\n"

1N/A . "See `perldoc perldoc' for more information on those switches.\n"

1N/A ;

1N/A }

1N/A}

1N/A

1N/A

1N/Asub render_and_page {

1N/A my($self, $found_list) = @_;

1N/A

1N/A $self->maybe_generate_dynamic_pod($found_list);

1N/A

1N/A my($out, $formatter) = $self->render_findings($found_list);

1N/A

1N/A if($self->opt_d) {

1N/A printf "Perldoc (%s) output saved to %s\n",

1N/A $self->{'formatter_class'} || ref($self),

1N/A $out;

1N/A print "But notice that it's 0 bytes long!\n" unless -s $out;

1N/A

1N/A

1N/A } elsif( # Allow the formatter to "page" itself, if it wants.

1N/A $formatter->can('page_for_perldoc')

1N/A and do {

1N/A $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");

1N/A if( $formatter->page_for_perldoc($out, $self) ) {

1N/A $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");

1N/A 1;

1N/A } else {

1N/A $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");

1N/A '';

1N/A }

1N/A }

1N/A ) {

1N/A # Do nothing, since the formatter has "paged" it for itself.

1N/A

1N/A } else {

1N/A # Page it normally (internally)

1N/A

1N/A if( -s $out ) { # Usual case:

1N/A $self->page($out, $self->{'output_to_stdout'}, $self->pagers);

1N/A

1N/A } else {

1N/A # Odd case:

1N/A $self->aside("Skipping $out (from $$found_list[0] "

1N/A . "via $$self{'formatter_class'}) as it is 0-length.\n");

1N/A

1N/A push @{ $self->{'temp_file_list'} }, $out;

1N/A $self->unlink_if_temp_file($out);

1N/A }

1N/A }

1N/A

1N/A $self->after_rendering(); # any extra cleanup or whatever

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub options_reading {

1N/A my $self = shift;

1N/A

1N/A if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {

1N/A require Text::ParseWords;

1N/A $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");

1N/A # Yes, appends to the beginning

1N/A unshift @{ $self->{'args'} },

1N/A Text::ParseWords::shellwords( $ENV{"PERLDOC"} )

1N/A ;

1N/A DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";

1N/A } else {

1N/A DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";

1N/A }

1N/A

1N/A DEBUG > 1

1N/A and print " Args right before switch processing: @{$self->{'args'}}\n";

1N/A

1N/A Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )

1N/A or return $self->usage;

1N/A

1N/A DEBUG > 1

1N/A and print " Args after switch processing: @{$self->{'args'}}\n";

1N/A

1N/A return $self->usage if $self->opt_h;

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub options_processing {

1N/A my $self = shift;

1N/A

1N/A if ($self->opt_X) {

1N/A my $podidx = "$Config{'archlib'}/pod.idx";

1N/A $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;

1N/A $self->{'podidx'} = $podidx;

1N/A }

1N/A

1N/A $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;

1N/A

1N/A $self->options_sanity;

1N/A

1N/A $self->opt_n("nroff") unless $self->opt_n;

1N/A $self->add_formatter_option( '__nroffer' => $self->opt_n );

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub options_sanity {

1N/A my $self = shift;

1N/A

1N/A # The opts-counting stuff interacts quite badly with

1N/A # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}

1N/A # set to -t, and I specify -u on the command line, I don't want

1N/A # to be hectored at that -u and -t don't make sense together.

1N/A

1N/A #my $opts = grep $_ && 1, # yes, the count of the set ones

1N/A # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l

1N/A #;

1N/A #

1N/A #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;

1N/A

1N/A

1N/A # Any sanity-checking need doing here?

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub grand_search_init {

1N/A my($self, $pages, @found) = @_;

1N/A

1N/A foreach (@$pages) {

1N/A if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {

1N/A my $searchfor = catfile split '::', $_;

1N/A $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );

1N/A local $_;

1N/A while (<PODIDX>) {

1N/A chomp;

1N/A push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;

1N/A }

1N/A close(PODIDX) or die "Can't close $$self{'podidx'}: $!";

1N/A next;

1N/A }

1N/A

1N/A $self->aside( "Searching for $_\n" );

1N/A

1N/A if ($self->opt_F) {

1N/A next unless -r;

1N/A push @found, $_ if $self->opt_m or $self->containspod($_);

1N/A next;

1N/A }

1N/A

1N/A # We must look both in @INC for library modules and in $bindir

1N/A # for executables, like h2xs or perldoc itself.

1N/A

1N/A my @searchdirs = ($self->{'bindir'}, @INC);

1N/A unless ($self->opt_m) {

1N/A if (IS_VMS) {

1N/A my($i,$trn);

1N/A for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {

1N/A push(@searchdirs,$trn);

1N/A }

1N/A push(@searchdirs,'perl_root:[lib.pod]') # installed pods

1N/A }

1N/A else {

1N/A push(@searchdirs, grep(-d, split($Config{path_sep},

1N/A $ENV{'PATH'})));

1N/A }

1N/A }

1N/A my @files = $self->searchfor(0,$_,@searchdirs);

1N/A if (@files) {

1N/A $self->aside( "Found as @files\n" );

1N/A }

1N/A else {

1N/A # no match, try recursive search

1N/A @searchdirs = grep(!/^\.\z/s,@INC);

1N/A @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;

1N/A if (@files) {

1N/A $self->aside( "Loosely found as @files\n" );

1N/A }

1N/A else {

1N/A print STDERR "No " .

1N/A ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";

1N/A if ( @{ $self->{'found'} } ) {

1N/A print STDERR "However, try\n";

1N/A for my $dir (@{ $self->{'found'} }) {

1N/A opendir(DIR, $dir) or die "opendir $dir: $!";

1N/A while (my $file = readdir(DIR)) {

1N/A next if ($file =~ /^\./s);

1N/A $file =~ s/\.(pm|pod)\z//; # XXX: badfs

1N/A print STDERR "\tperldoc $_\::$file\n";

1N/A }

1N/A closedir(DIR) or die "closedir $dir: $!";

1N/A }

1N/A }

1N/A }

1N/A }

1N/A push(@found,@files);

1N/A }

1N/A return @found;

1N/A}

1N/A

1N/A

1N/Asub maybe_generate_dynamic_pod {

1N/A my($self, $found_things) = @_;

1N/A my @dynamic_pod;

1N/A

1N/A $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;

1N/A

1N/A $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;

1N/A

1N/A if( ! $self->opt_f and ! $self->opt_q ) {

1N/A DEBUG > 4 and print "That's a non-dynamic pod search.\n";

1N/A } elsif ( @dynamic_pod ) {

1N/A $self->aside("Hm, I found some Pod from that search!\n");

1N/A my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');

1N/A

1N/A push @{ $self->{'temp_file_list'} }, $buffer;

1N/A # I.e., it MIGHT be deleted at the end.

1N/A

1N/A my $in_list = $self->opt_f;

1N/A

1N/A print $buffd "=over 8\n\n" if $in_list;

1N/A print $buffd @dynamic_pod or die "Can't print $buffer: $!";

1N/A print $buffd "=back\n" if $in_list;

1N/A

1N/A close $buffd or die "Can't close $buffer: $!";

1N/A

1N/A @$found_things = $buffer;

1N/A # Yes, so found_things never has more than one thing in

1N/A # it, by time we leave here

1N/A

1N/A $self->add_formatter_option('__filter_nroff' => 1);

1N/A

1N/A } else {

1N/A @$found_things = ();

1N/A $self->aside("I found no Pod from that search!\n");

1N/A }

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub add_formatter_option { # $self->add_formatter_option('key' => 'value');

1N/A my $self = shift;

1N/A push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;

1N/A

1N/A DEBUG > 3 and printf "Formatter switches now: [%s]\n",

1N/A join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub search_perlfunc {

1N/A my($self, $found_things, $pod) = @_;

1N/A

1N/A DEBUG > 2 and print "Search: @$found_things\n";

1N/A

1N/A my $perlfunc = shift @$found_things;

1N/A open(PFUNC, "<", $perlfunc) # "Funk is its own reward"

1N/A or die("Can't open $perlfunc: $!");

1N/A

1N/A # Functions like -r, -e, etc. are listed under `-X'.

1N/A my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)

1N/A ? '(?:I<)?-X' : quotemeta($self->opt_f) ;

1N/A

1N/A DEBUG > 2 and

1N/A print "Going to perlfunc-scan for $search_re in $perlfunc\n";

1N/A

1N/A # Skip introduction

1N/A local $_;

1N/A while (<PFUNC>) {

1N/A last if /^=head2 Alphabetical Listing of Perl Functions/;

1N/A }

1N/A

1N/A # Look for our function

1N/A my $found = 0;

1N/A my $inlist = 0;

1N/A while (<PFUNC>) { # "The Mothership Connection is here!"

1N/A if ( m/^=item\s+$search_re\b/ ) {

1N/A $found = 1;

1N/A }

1N/A elsif (/^=item/) {

1N/A last if $found > 1 and not $inlist;

1N/A }

1N/A next unless $found;

1N/A if (/^=over/) {

1N/A ++$inlist;

1N/A }

1N/A elsif (/^=back/) {

1N/A --$inlist;

1N/A }

1N/A push @$pod, $_;

1N/A ++$found if /^\w/; # found descriptive text

1N/A }

1N/A if (!@$pod) {

1N/A die sprintf

1N/A "No documentation for perl function `%s' found\n",

1N/A $self->opt_f

1N/A ;

1N/A }

1N/A close PFUNC or die "Can't open $perlfunc: $!";

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub search_perlfaqs {

1N/A my( $self, $found_things, $pod) = @_;

1N/A

1N/A my $found = 0;

1N/A my %found_in;

1N/A my $search_key = $self->opt_q;

1N/A

1N/A my $rx = eval { qr/$search_key/ }

1N/A or die <<EOD;

1N/AInvalid regular expression '$search_key' given as -q pattern:

1N/A$@

1N/ADid you mean \\Q$search_key ?

1N/A

1N/A

1N/A local $_;

1N/A foreach my $file (@$found_things) {

1N/A die "invalid file spec: $!" if $file =~ /[<>|]/;

1N/A open(INFAQ, "<", $file) # XXX 5.6ism

1N/A or die "Can't read-open $file: $!\nAborting";

1N/A while (<INFAQ>) {

1N/A if ( m/^=head2\s+.*(?:$search_key)/i ) {

1N/A $found = 1;

1N/A push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;

1N/A }

1N/A elsif (/^=head[12]/) {

1N/A $found = 0;

1N/A }

1N/A next unless $found;

1N/A push @$pod, $_;

1N/A }

1N/A close(INFAQ);

1N/A }

1N/A die("No documentation for perl FAQ keyword `$search_key' found\n")

1N/A unless @$pod;

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/A

1N/Asub render_findings {

1N/A # Return the filename to open

1N/A

1N/A my($self, $found_things) = @_;

1N/A

1N/A my $formatter_class = $self->{'formatter_class'}

1N/A || die "No formatter class set!?";

1N/A my $formatter = $formatter_class->can('new')

1N/A ? $formatter_class->new

1N/A : $formatter_class

1N/A ;

1N/A

1N/A if(! @$found_things) {

1N/A die "Nothing found?!";

1N/A # should have been caught before here

1N/A } elsif(@$found_things > 1) {

1N/A warn join '',

1N/A "Perldoc is only really meant for reading one document at a time.\n",

1N/A "So these parameters are being ignored: ",

1N/A join(' ', @$found_things[1 .. $#$found_things] ),

1N/A "\n"

1N/A }

1N/A

1N/A my $file = $found_things->[0];

1N/A

1N/A DEBUG > 3 and printf "Formatter switches now: [%s]\n",

1N/A join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };

1N/A

1N/A # Set formatter options:

1N/A if( ref $formatter ) {

1N/A foreach my $f (@{ $self->{'formatter_switches'} || [] }) {

1N/A my($switch, $value, $silent_fail) = @$f;

1N/A if( $formatter->can($switch) ) {

1N/A eval { $formatter->$switch( defined($value) ? $value : () ) };

1N/A warn "Got an error when setting $formatter_class\->$switch:\n$@\n"

1N/A if $@;

1N/A } else {

1N/A if( $silent_fail or $switch =~ m/^__/s ) {

1N/A DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";

1N/A } else {

1N/A warn "$formatter_class doesn't recognize the $switch switch.\n";

1N/A }

1N/A }

1N/A }

1N/A }

1N/A

1N/A $self->{'output_is_binary'} =

1N/A $formatter->can('write_with_binmode') && $formatter->write_with_binmode;

1N/A

1N/A my ($out_fh, $out) = $self->new_output_file(

1N/A ( $formatter->can('output_extension') && $formatter->output_extension )

1N/A || undef,

1N/A $self->useful_filename_bit,

1N/A );

1N/A

1N/A # Now, finally, do the formatting!

1N/A {

1N/A local $^W = $^W;

1N/A if(DEBUG() or $self->opt_v) {

1N/A # feh, let 'em see it

1N/A } else {

1N/A $^W = 0;

1N/A # The average user just has no reason to be seeing

1N/A # $^W-suppressable warnings from the formatting!

1N/A }

1N/A

1N/A eval { $formatter->parse_from_file( $file, $out_fh ) };

1N/A }

1N/A

1N/A warn "Error while formatting with $formatter_class:\n $@\n" if $@;

1N/A DEBUG > 2 and print "Back from formatting with $formatter_class\n";

1N/A

1N/A close $out_fh

1N/A or warn "Can't close $out: $!\n(Did $formatter already close it?)";

1N/A sleep 0; sleep 0; sleep 0;

1N/A # Give the system a few timeslices to meditate on the fact

1N/A # that the output file does in fact exist and is closed.

1N/A

1N/A $self->unlink_if_temp_file($file);

1N/A

1N/A unless( -s $out ) {

1N/A if( $formatter->can( 'if_zero_length' ) ) {

1N/A # Basically this is just a hook for Pod::Simple::Checker; since

1N/A # what other class could /happily/ format an input file with Pod

1N/A # as a 0-length output file?

1N/A $formatter->if_zero_length( $file, $out, $out_fh );

1N/A } else {

1N/A warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"

1N/A }

1N/A }

1N/A

1N/A DEBUG and print "Finished writing to $out.\n";

1N/A return($out, $formatter) if wantarray;

1N/A return $out;

1N/A}

1N/A

1N/A

1N/Asub unlink_if_temp_file {

1N/A # Unlink the specified file IFF it's in the list of temp files.

1N/A # Really only used in the case of -f / -q things when we can

1N/A # throw away the dynamically generated source pod file once

1N/A # we've formatted it.

1N/A #

1N/A my($self, $file) = @_;

1N/A return unless defined $file and length $file;

1N/A

1N/A my $temp_file_list = $self->{'temp_file_list'} || return;

1N/A if(grep $_ eq $file, @$temp_file_list) {

1N/A $self->aside("Unlinking $file\n");

1N/A unlink($file) or warn "Odd, couldn't unlink $file: $!";

1N/A } else {

1N/A DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";

1N/A }

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub MSWin_temp_cleanup {

1N/A

1N/A # Nothing particularly MSWin-specific in here, but I don't know if any

1N/A # other OS needs its temp dir policed like MSWin does!

1N/A

1N/A my $self = shift;

1N/A

1N/A my $tempdir = $ENV{'TEMP'};

1N/A return unless defined $tempdir and length $tempdir

1N/A and -e $tempdir and -d _ and -w _;

1N/A

1N/A $self->aside(

1N/A "Considering whether any old files of mine in $tempdir need unlinking.\n"

1N/A );

1N/A

1N/A opendir(TMPDIR, $tempdir) || return;

1N/A my @to_unlink;

1N/A

1N/A my $limit = time() - $Temp_File_Lifetime;

1N/A

1N/A DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",

1N/A ($limit) x 2;

1N/A

1N/A my $filespec;

1N/A

1N/A while(defined($filespec = readdir(TMPDIR))) {

1N/A if(

1N/A $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s

1N/A ) {

1N/A if( hex($1) < $limit ) {

1N/A push @to_unlink, "$tempdir/$filespec";

1N/A $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );

1N/A } else {

1N/A DEBUG > 5 and

1N/A printf " $tempdir/$filespec is too recent (after %x)\n", $limit;

1N/A }

1N/A } else {

1N/A DEBUG > 5 and

1N/A print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";

1N/A }

1N/A }

1N/A closedir(TMPDIR);

1N/A $self->aside(sprintf "Unlinked %s items of mine in %s\n",

1N/A scalar(unlink(@to_unlink)),

1N/A $tempdir

1N/A );

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub MSWin_perldoc_tempfile {

1N/A my($self, $suffix, $infix) = @_;

1N/A

1N/A my $tempdir = $ENV{'TEMP'};

1N/A return unless defined $tempdir and length $tempdir

1N/A and -e $tempdir and -d _ and -w _;

1N/A

1N/A my $spec;

1N/A

1N/A do {

1N/A $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup

1N/A # Yes, we embed the create-time in the filename!

1N/A $tempdir,

1N/A $infix || 'x',

1N/A time(),

1N/A $$,

1N/A defined( &Win32::GetTickCount )

1N/A ? (Win32::GetTickCount() & 0xff)

1N/A : int(rand 256)

1N/A # Under MSWin, $$ values get reused quickly! So if we ran

1N/A # perldoc foo and then perldoc bar before there was time for

1N/A # time() to increment time."_$$" would likely be the same

1N/A # for each process! So we tack on the tick count's lower

1N/A # bits (or, in a pinch, rand)

1N/A ,

1N/A $suffix || 'txt';

1N/A ;

1N/A } while( -e $spec );

1N/A

1N/A my $counter = 0;

1N/A

1N/A while($counter < 50) {

1N/A my $fh;

1N/A # If we are running before perl5.6.0, we can't autovivify

1N/A if ($] < 5.006) {

1N/A require Symbol;

1N/A $fh = Symbol::gensym();

1N/A }

1N/A DEBUG > 3 and print "About to try making temp file $spec\n";

1N/A return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism

1N/A $self->aside("Can't create temp file $spec: $!\n");

1N/A }

1N/A

1N/A $self->aside("Giving up on making a temp file!\n");

1N/A die "Can't make a tempfile!?";

1N/A}

1N/A

1N/A

1N/A

1N/Asub after_rendering {

1N/A my $self = $_[0];

1N/A $self->after_rendering_VMS if IS_VMS;

1N/A $self->after_rendering_MSWin32 if IS_MSWin32;

1N/A $self->after_rendering_Dos if IS_Dos;

1N/A $self->after_rendering_OS2 if IS_OS2;

1N/A return;

1N/A}

1N/A

1N/Asub after_rendering_VMS { return }

1N/Asub after_rendering_Dos { return }

1N/Asub after_rendering_OS2 { return }

1N/A

1N/Asub after_rendering_MSWin32 {

1N/A shift->MSWin_temp_cleanup() if $Temp_Files_Created;

1N/A}

1N/A

1N/A

1N/A

1N/Asub minus_f_nocase { # i.e., do like -f, but without regard to case

1N/A

1N/A my($self, $dir, $file) = @_;

1N/A my $path = catfile($dir,$file);

1N/A return $path if -f $path and -r _;

1N/A

1N/A if(!$self->opt_i

1N/A or IS_VMS or IS_MSWin32

1N/A or IS_Dos or IS_OS2

1N/A ) {

1N/A # On a case-forgiving file system, or if case is important,

1N/A # that is it, all we can do.

1N/A warn "Ignored $path: unreadable\n" if -f _;

1N/A return '';

1N/A }

1N/A

1N/A local *DIR;

1N/A my @p = ($dir);

1N/A my($p,$cip);

1N/A foreach $p (splitdir $file){

1N/A my $try = catfile @p, $p;

1N/A $self->aside("Scrutinizing $try...\n");

1N/A stat $try;

1N/A if (-d _) {

1N/A push @p, $p;

1N/A if ( $p eq $self->{'target'} ) {

1N/A my $tmp_path = catfile @p;

1N/A my $path_f = 0;

1N/A for (@{ $self->{'found'} }) {

1N/A $path_f = 1 if $_ eq $tmp_path;

1N/A }

1N/A push (@{ $self->{'found'} }, $tmp_path) unless $path_f;

1N/A $self->aside( "Found as $tmp_path but directory\n" );

1N/A }

1N/A }

1N/A elsif (-f _ && -r _) {

1N/A return $try;

1N/A }

1N/A elsif (-f _) {

1N/A warn "Ignored $try: unreadable\n";

1N/A }

1N/A elsif (-d catdir(@p)) { # at least we see the containing directory!

1N/A my $found = 0;

1N/A my $lcp = lc $p;

1N/A my $p_dirspec = catdir(@p);

1N/A opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";

1N/A while(defined( $cip = readdir(DIR) )) {

1N/A if (lc $cip eq $lcp){

1N/A $found++;

1N/A last; # XXX stop at the first? what if there's others?

1N/A }

1N/A }

1N/A closedir DIR or die "closedir $p_dirspec: $!";

1N/A return "" unless $found;

1N/A

1N/A push @p, $cip;

1N/A my $p_filespec = catfile(@p);

1N/A return $p_filespec if -f $p_filespec and -r _;

1N/A warn "Ignored $p_filespec: unreadable\n" if -f _;

1N/A }

1N/A }

1N/A return "";

1N/A}

1N/A

1N/A

1N/Asub pagers_guessing {

1N/A my $self = shift;

1N/A

1N/A my @pagers;

1N/A push @pagers, $self->pagers;

1N/A $self->{'pagers'} = \@pagers;

1N/A

1N/A if (IS_MSWin32) {

1N/A push @pagers, qw( more< less notepad );

1N/A unshift @pagers, $ENV{PAGER} if $ENV{PAGER};

1N/A }

1N/A elsif (IS_VMS) {

1N/A push @pagers, qw( most more less type/page );

1N/A }

1N/A elsif (IS_Dos) {

1N/A push @pagers, qw( less.exe more.com< );

1N/A unshift @pagers, $ENV{PAGER} if $ENV{PAGER};

1N/A }

1N/A else {

1N/A if (IS_OS2) {

1N/A unshift @pagers, 'less', 'cmd /c more <';

1N/A }

1N/A push @pagers, qw( more less pg view cat );

1N/A unshift @pagers, $ENV{PAGER} if $ENV{PAGER};

1N/A }

1N/A unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};

1N/A

1N/A return;

1N/A}

1N/A

1N/A

1N/Asub page_module_file {

1N/A my($self, @found) = @_;

1N/A

1N/A # Security note:

1N/A # Don't ever just pass this off to anything like MSWin's "start.exe",

1N/A # since we might be calling on a .pl file, and we wouldn't want that

1N/A # to actually /execute/ the file that we just want to page thru!

1N/A # Also a consideration if one were to use a web browser as a pager;

1N/A # doing so could trigger the browser's MIME mapping for whatever

1N/A # it thinks .pm/.pl/whatever is. Probably just a (useless and

1N/A # annoying) "Save as..." dialog, but potentially executing the file

1N/A # in question -- particularly in the case of MSIE and it's, ahem,

1N/A # occasionally hazy distinction between OS-local extension

1N/A # associations, and browser-specific MIME mappings.

1N/A

1N/A if ($self->{'output_to_stdout'}) {

1N/A $self->aside("Sending unpaged output to STDOUT.\n");

1N/A local $_;

1N/A my $any_error = 0;

1N/A foreach my $output (@found) {

1N/A unless( open(TMP, "<", $output) ) { # XXX 5.6ism

1N/A warn("Can't open $output: $!");

1N/A $any_error = 1;

1N/A next;

1N/A }

1N/A while (<TMP>) {

1N/A print or die "Can't print to stdout: $!";

1N/A }

1N/A close TMP or die "Can't close while $output: $!";

1N/A $self->unlink_if_temp_file($output);

1N/A }

1N/A return $any_error; # successful

1N/A }

1N/A

1N/A foreach my $pager ( $self->pagers ) {

1N/A $self->aside("About to try calling $pager @found\n");

1N/A if (system($pager, @found) == 0) {

1N/A $self->aside("Yay, it worked.\n");

1N/A return 0;

1N/A }

1N/A $self->aside("That didn't work.\n");

1N/A

1N/A # Odd -- when it fails, under Win32, this seems to neither

1N/A # return with a fail nor return with a success!!

1N/A # That's discouraging!

1N/A }

1N/A

1N/A $self->aside(

1N/A sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",

1N/A join(' ', @found),

1N/A join(' ', $self->pagers),

1N/A );

1N/A

1N/A if (IS_VMS) {

1N/A DEBUG > 1 and print "Bailing out in a VMSish way.\n";

1N/A eval q{

1N/A use vmsish qw(status exit);

1N/A exit $?;

1N/A 1;

1N/A } or die;