Profile of Pod/Perldoc.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/share/perl/5.18/Pod/Perldoc.pm
Statements | Executed 79 statements in 8.55ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 809µs | 857µs | Pod::Perldoc::::BEGIN@30 Pod::Perldoc::BEGIN@30
1 | 1 | 1 | 19µs | 19µs | PONAPI::CLI::Command::manual::::BEGIN@1PONAPI::CLI::Command::manual::BEGIN@1
1 | 1 | 1 | 19µs | 19µs | Pod::Perldoc::::CORE:fteexec Pod::Perldoc::CORE:fteexec (opcode)
1 | 1 | 1 | 11µs | 21µs | Pod::Perldoc::::BEGIN@94 Pod::Perldoc::BEGIN@94
1 | 1 | 1 | 10µs | 11µs | Pod::Perldoc::::BEGIN@64 Pod::Perldoc::BEGIN@64
1 | 1 | 1 | 9µs | 9µs | Pod::Perldoc::::BEGIN@19 Pod::Perldoc::BEGIN@19
1 | 1 | 1 | 8µs | 203µs | Pod::Perldoc::::BEGIN@8 Pod::Perldoc::BEGIN@8
1 | 1 | 1 | 8µs | 42µs | Pod::Perldoc::::BEGIN@9 Pod::Perldoc::BEGIN@9
1 | 1 | 1 | 8µs | 33µs | Pod::Perldoc::::BEGIN@10 Pod::Perldoc::BEGIN@10
1 | 1 | 1 | 7µs | 12µs | Pod::Perldoc::::BEGIN@5 Pod::Perldoc::BEGIN@5
1 | 1 | 1 | 7µs | 35µs | Pod::Perldoc::::BEGIN@31 Pod::Perldoc::BEGIN@31
1 | 1 | 1 | 6µs | 17µs | Pod::Perldoc::::BEGIN@6 Pod::Perldoc::BEGIN@6
1 | 1 | 1 | 6µs | 67µs | Pod::Perldoc::::BEGIN@12 Pod::Perldoc::BEGIN@12
1 | 1 | 1 | 6µs | 17µs | Pod::Perldoc::::BEGIN@4 Pod::Perldoc::BEGIN@4
1 | 1 | 1 | 5µs | 13µs | Pod::Perldoc::::BEGIN@95 Pod::Perldoc::BEGIN@95
2 | 2 | 1 | 1µs | 1µs | Pod::Perldoc::::CORE:match Pod::Perldoc::CORE:match (opcode)
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::FALSE Pod::Perldoc::FALSE
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::__ANON__[:95] Pod::Perldoc::__ANON__[:95]
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::_elem Pod::Perldoc::_elem
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::add_formatter_option Pod::Perldoc::add_formatter_option
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::add_translator Pod::Perldoc::add_translator
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::after_rendering Pod::Perldoc::after_rendering
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::after_rendering_Dos Pod::Perldoc::after_rendering_Dos
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::after_rendering_MSWin32 Pod::Perldoc::after_rendering_MSWin32
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::after_rendering_OS2 Pod::Perldoc::after_rendering_OS2
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::after_rendering_VMS Pod::Perldoc::after_rendering_VMS
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::am_taint_checking Pod::Perldoc::am_taint_checking
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::aside Pod::Perldoc::aside
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::assert_closing_stdout Pod::Perldoc::assert_closing_stdout
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::check_file Pod::Perldoc::check_file
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::containspod Pod::Perldoc::containspod
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::debug Pod::Perldoc::debug
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::debugging Pod::Perldoc::debugging
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::die Pod::Perldoc::die
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::drop_privs_maybe Pod::Perldoc::drop_privs_maybe
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::find_good_formatter_class Pod::Perldoc::find_good_formatter_class
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::formatter_sanity_check Pod::Perldoc::formatter_sanity_check
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::grand_search_init Pod::Perldoc::grand_search_init
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::init Pod::Perldoc::init
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::init_formatter_class_list Pod::Perldoc::init_formatter_class_list
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::is_tainted Pod::Perldoc::is_tainted
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::isprintable Pod::Perldoc::isprintable
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::maybe_diddle_INC Pod::Perldoc::maybe_diddle_INC
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::maybe_generate_dynamic_pod Pod::Perldoc::maybe_generate_dynamic_pod
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::minus_f_nocase Pod::Perldoc::minus_f_nocase
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::new Pod::Perldoc::new
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::new_output_file Pod::Perldoc::new_output_file
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::new_tempfile Pod::Perldoc::new_tempfile
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::new_translator Pod::Perldoc::new_translator
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::not_dynamic Pod::Perldoc::not_dynamic
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_L_with Pod::Perldoc::opt_L_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_M_with Pod::Perldoc::opt_M_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_V Pod::Perldoc::opt_V
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_d_with Pod::Perldoc::opt_d_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_f_with Pod::Perldoc::opt_f_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_n_with Pod::Perldoc::opt_n_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_o_with Pod::Perldoc::opt_o_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_q_with Pod::Perldoc::opt_q_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_t Pod::Perldoc::opt_t
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_u Pod::Perldoc::opt_u
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_v_with Pod::Perldoc::opt_v_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::opt_w_with Pod::Perldoc::opt_w_with
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::options_processing Pod::Perldoc::options_processing
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::options_reading Pod::Perldoc::options_reading
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::options_sanity Pod::Perldoc::options_sanity
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::page Pod::Perldoc::page
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::page_module_file Pod::Perldoc::page_module_file
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::pagers Pod::Perldoc::pagers
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::pagers_guessing Pod::Perldoc::pagers_guessing
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::process Pod::Perldoc::process
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::program_name Pod::Perldoc::program_name
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::render_and_page Pod::Perldoc::render_and_page
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::render_findings Pod::Perldoc::render_findings
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::run Pod::Perldoc::run
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::search_perlfaqs Pod::Perldoc::search_perlfaqs
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::search_perlfunc Pod::Perldoc::search_perlfunc
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::search_perlop Pod::Perldoc::search_perlop
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::search_perlvar Pod::Perldoc::search_perlvar
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::searchfor Pod::Perldoc::searchfor
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::tweak_found_pathnames Pod::Perldoc::tweak_found_pathnames
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::unlink_if_temp_file Pod::Perldoc::unlink_if_temp_file
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::usage Pod::Perldoc::usage
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::usage_brief Pod::Perldoc::usage_brief
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::useful_filename_bit Pod::Perldoc::useful_filename_bit
0 | 0 | 0 | 0s | 0s | Pod::Perldoc::::warn Pod::Perldoc::warn

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 | 2 | 50µs | 1 | 19µs | # spent 19µs within PONAPI::CLI::Command::manual::BEGIN@1 which was called: # once (19µs+0s) by PONAPI::CLI::Command::manual::BEGIN@9 at line 1 use 5.006; # we use some open(X, "<", $y) syntax # spent 19µs making 1 call to PONAPI::CLI::Command::manual::BEGIN@1
2 |  |  |  |  |
3 |  |  |  |  | package Pod::Perldoc;
4 | 2 | 19µs | 2 | 28µs | # spent 17µs (6+11) within Pod::Perldoc::BEGIN@4 which was called: # once (6µs+11µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 4 use strict; # spent 17µs making 1 call to Pod::Perldoc::BEGIN@4 # spent 11µs making 1 call to strict::import
5 | 2 | 22µs | 2 | 17µs | # spent 12µs (7+5) within Pod::Perldoc::BEGIN@5 which was called: # once (7µs+5µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 5 use warnings; # spent 12µs making 1 call to Pod::Perldoc::BEGIN@5 # spent 5µs making 1 call to warnings::import
6 | 2 | 22µs | 2 | 28µs | # spent 17µs (6+11) within Pod::Perldoc::BEGIN@6 which was called: # once (6µs+11µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 6 use Config '%Config'; # spent 17µs making 1 call to Pod::Perldoc::BEGIN@6 # spent 11µs making 1 call to Config::import
7 |  |  |  |  |
8 | 2 | 24µs | 2 | 398µs | # spent 203µs (8+195) within Pod::Perldoc::BEGIN@8 which was called: # once (8µs+195µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 8 use Fcntl; # for sysopen # spent 203µs making 1 call to Pod::Perldoc::BEGIN@8 # spent 195µs making 1 call to Exporter::import
9 | 2 | 24µs | 2 | 76µs | # spent 42µs (8+34) within Pod::Perldoc::BEGIN@9 which was called: # once (8µs+34µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 9 use File::Basename qw(basename); # spent 42µs making 1 call to Pod::Perldoc::BEGIN@9 # spent 34µs making 1 call to Exporter::import
10 | 2 | 28µs | 2 | 58µs | # spent 33µs (8+25) within Pod::Perldoc::BEGIN@10 which was called: # once (8µs+25µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 10 use File::Spec::Functions qw(catfile catdir splitdir); # spent 33µs making 1 call to Pod::Perldoc::BEGIN@10 # spent 25µs making 1 call to Exporter::import
11 |  |  |  |  |
12 | 1 | 4µs | 1 | 61µs | # spent 67µs (6+61) within Pod::Perldoc::BEGIN@12 which was called: # once (6µs+61µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 14 use vars qw($VERSION @Pagers $Bindir $Pod2man # spent 61µs making 1 call to vars::import
13 |  |  |  |  | $Temp_Files_Created $Temp_File_Lifetime
14 | 1 | 90µs | 1 | 67µs | ); # spent 67µs making 1 call to Pod::Perldoc::BEGIN@12
15 | 1 | 600ns |  |  | $VERSION = '3.19';
16 |  |  |  |  |
17 |  |  |  |  | #..........................................................................
18 |  |  |  |  |
19 |  |  |  |  | # spent 9µs (9+300ns) within Pod::Perldoc::BEGIN@19 which was called: # once (9µs+300ns) by PONAPI::CLI::Command::manual::BEGIN@9 at line 28 BEGIN { # Make a DEBUG constant very first thing...
20 | 1 | 4µs |  |  | unless(defined &DEBUG) {
21 | 1 | 5µs | 1 | 300ns | if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint # spent 300ns making 1 call to Pod::Perldoc::CORE:match
22 |  |  |  |  | eval("sub DEBUG () {$1}");
23 |  |  |  |  | die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
24 |  |  |  |  | } else {
25 | 1 | 800ns |  |  | *DEBUG = sub () {0};
26 |  |  |  |  | }
27 |  |  |  |  | }
28 | 1 | 18µs | 1 | 9µs | } # spent 9µs making 1 call to Pod::Perldoc::BEGIN@19
29 |  |  |  |  |
30 | 2 | 421µs | 1 | 857µs | # spent 857µs (809+48) within Pod::Perldoc::BEGIN@30 which was called: # once (809µs+48µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 30 use Pod::Perldoc::GetOptsOO; # uses the DEBUG. # spent 857µs making 1 call to Pod::Perldoc::BEGIN@30
31 | 2 | 269µs | 2 | 63µs | # spent 35µs (7+28) within Pod::Perldoc::BEGIN@31 which was called: # once (7µs+28µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 31 use Carp qw(croak carp); # spent 35µs making 1 call to Pod::Perldoc::BEGIN@31 # spent 28µs making 1 call to Exporter::import
32 |  |  |  |  |
33 |  |  |  |  | # these are also in BaseTo, which I don't want to inherit
34 |  |  |  |  | sub debugging {
35 |  |  |  |  | my $self = shift;
36 |  |  |  |  |
37 |  |  |  |  | ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() )
38 |  |  |  |  | }
39 |  |  |  |  |
40 |  |  |  |  | sub debug {
41 |  |  |  |  | my( $self, @messages ) = @_;
42 |  |  |  |  | return unless $self->debugging;
43 |  |  |  |  | print STDERR map { "DEBUG : $_" } @messages;
44 |  |  |  |  | }
45 |  |  |  |  |
46 |  |  |  |  | sub warn {
47 |  |  |  |  | my( $self, @messages ) = @_;
48 |  |  |  |  |
49 |  |  |  |  | carp( join "\n", @messages, '' );
50 |  |  |  |  | }
51 |  |  |  |  |
52 |  |  |  |  | sub die {
53 |  |  |  |  | my( $self, @messages ) = @_;
54 |  |  |  |  |
55 |  |  |  |  | croak( join "\n", @messages, '' );
56 |  |  |  |  | }
57 |  |  |  |  |
58 |  |  |  |  | #..........................................................................
59 |  |  |  |  |
60 |  |  |  |  | sub TRUE () {1}
61 |  |  |  |  | sub FALSE () {return}
62 |  |  |  |  | sub BE_LENIENT () {1}
63 |  |  |  |  |
64 |  |  |  |  | # spent 11µs (10+800ns) within Pod::Perldoc::BEGIN@64 which was called: # once (10µs+800ns) by PONAPI::CLI::Command::manual::BEGIN@9 at line 72 BEGIN {
65 | 1 | 2µs |  |  | *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms;
66 | 1 | 500ns |  |  | *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
67 | 1 | 400ns |  |  | *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos;
68 | 1 | 300ns |  |  | *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2;
69 | 1 | 300ns |  |  | *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin;
70 | 1 | 400ns |  |  | *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux;
71 | 1 | 7µs | 1 | 800ns | *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; # spent 800ns making 1 call to Pod::Perldoc::CORE:match
72 | 1 | 96µs | 1 | 11µs | } # spent 11µs making 1 call to Pod::Perldoc::BEGIN@64
73 |  |  |  |  |
74 | 1 | 300ns |  |  | $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
75 |  |  |  |  | # If it's older than five days, it's quite unlikely
76 |  |  |  |  | # that anyone's still looking at it!!
77 |  |  |  |  | # (Currently used only by the MSWin cleanup routine)
78 |  |  |  |  |
79 |  |  |  |  |
80 |  |  |  |  | #..........................................................................
81 | 2 | 10µs | 1 | 1.89ms | { my $pager = $Config{'pager'}; # spent 1.89ms making 1 call to Config::FETCH
82 | 1 | 27µs | 1 | 19µs | push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms; # spent 19µs making 1 call to Pod::Perldoc::CORE:fteexec
83 |  |  |  |  | }
84 | 1 | 5µs | 1 | 33µs | $Bindir = $Config{'scriptdirexp'}; # spent 33µs making 1 call to Config::FETCH
85 | 1 | 4µs | 1 | 31µs | $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); # spent 31µs making 1 call to Config::FETCH
86 |  |  |  |  |
87 |  |  |  |  | # End of class-init stuff
88 |  |  |  |  | #
89 |  |  |  |  | ###########################################################################
90 |  |  |  |  | #
91 |  |  |  |  | # Option accessors...
92 |  |  |  |  |
93 | 1 | 7µs |  |  | foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) {
94 | 2 | 24µs | 2 | 32µs | # spent 21µs (11+10) within Pod::Perldoc::BEGIN@94 which was called: # once (11µs+10µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 94 no strict 'refs'; # spent 21µs making 1 call to Pod::Perldoc::BEGIN@94 # spent 10µs making 1 call to strict::unimport
95 | 34 | 7.35ms | 2 | 21µs | # spent 13µs (5+8) within Pod::Perldoc::BEGIN@95 which was called: # once (5µs+8µs) by PONAPI::CLI::Command::manual::BEGIN@9 at line 95 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; # spent 13µs making 1 call to Pod::Perldoc::BEGIN@95 # spent 8µs making 1 call to strict::import
96 |  |  |  |  | }
97 |  |  |  |  |
98 |  |  |  |  | # And these are so that GetOptsOO knows they take options:
99 |  |  |  |  | sub opt_f_with { shift->_elem('opt_f', @_) }
100 |  |  |  |  | sub opt_q_with { shift->_elem('opt_q', @_) }
101 |  |  |  |  | sub opt_d_with { shift->_elem('opt_d', @_) }
102 |  |  |  |  | sub opt_L_with { shift->_elem('opt_L', @_) }
103 |  |  |  |  | sub opt_v_with { shift->_elem('opt_v', @_) }
104 |  |  |  |  |
105 |  |  |  |  | sub opt_w_with { # Specify an option for the formatter subclass
106 |  |  |  |  | my($self, $value) = @_;
107 |  |  |  |  | if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
108 |  |  |  |  | my $option = $1;
109 |  |  |  |  | my $option_value = defined($2) ? $2 : "TRUE";
110 |  |  |  |  | $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
111 |  |  |  |  | $self->add_formatter_option( $option, $option_value );
112 |  |  |  |  | } else {
113 |  |  |  |  | $self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) );
114 |  |  |  |  | }
115 |  |  |  |  | return;
116 |  |  |  |  | }
117 |  |  |  |  |
118 |  |  |  |  | sub opt_M_with { # specify formatter class name(s)
119 |  |  |  |  | my($self, $classes) = @_;
120 |  |  |  |  | return unless defined $classes and length $classes;
121 |  |  |  |  | DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
122 |  |  |  |  | my @classes_to_add;
123 |  |  |  |  | foreach my $classname (split m/[,;]+/s, $classes) {
124 |  |  |  |  | next unless $classname =~ m/\S/;
125 |  |  |  |  | if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
126 |  |  |  |  | # A mildly restrictive concept of what modulenames are valid.
127 |  |  |  |  | push @classes_to_add, $1; # untaint
128 |  |  |  |  | } else {
129 |  |  |  |  | $self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) );
130 |  |  |  |  | }
131 |  |  |  |  | }
132 |  |  |  |  |
133 |  |  |  |  | unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
134 |  |  |  |  |
135 |  |  |  |  | DEBUG > 3 and print(
136 |  |  |  |  | "Adding @classes_to_add to the list of formatter classes, "
137 |  |  |  |  | . "making them @{ $self->{'formatter_classes'} }.\n"
138 |  |  |  |  | );
139 |  |  |  |  |
140 |  |  |  |  | return;
141 |  |  |  |  | }
142 |  |  |  |  |
143 |  |  |  |  | sub opt_V { # report version and exit
144 |  |  |  |  | print join '',
145 |  |  |  |  | "Perldoc v$VERSION, under perl v$] for $^O",
146 |  |  |  |  |
147 |  |  |  |  | (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
148 |  |  |  |  | ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
149 |  |  |  |  |
150 |  |  |  |  | (chr(65) eq 'A') ? () : " (non-ASCII)",
151 |  |  |  |  |
152 |  |  |  |  | "\n",
153 |  |  |  |  | ;
154 |  |  |  |  | exit;
155 |  |  |  |  | }
156 |  |  |  |  |
157 |  |  |  |  | sub opt_t { # choose plaintext as output format
158 |  |  |  |  | my $self = shift;
159 |  |  |  |  | $self->opt_o_with('text') if @_ and $_[0];
160 |  |  |  |  | return $self->_elem('opt_t', @_);
161 |  |  |  |  | }
162 |  |  |  |  |
163 |  |  |  |  | sub opt_u { # choose raw pod as output format
164 |  |  |  |  | my $self = shift;
165 |  |  |  |  | $self->opt_o_with('pod') if @_ and $_[0];
166 |  |  |  |  | return $self->_elem('opt_u', @_);
167 |  |  |  |  | }
168 |  |  |  |  |
169 |  |  |  |  | sub opt_n_with {
170 |  |  |  |  | # choose man as the output format, and specify the proggy to run
171 |  |  |  |  | my $self = shift;
172 |  |  |  |  | $self->opt_o_with('man') if @_ and $_[0];
173 |  |  |  |  | $self->_elem('opt_n', @_);
174 |  |  |  |  | }
175 |  |  |  |  |
176 |  |  |  |  | sub opt_o_with { # "o" for output format
177 |  |  |  |  | my($self, $rest) = @_;
178 |  |  |  |  | return unless defined $rest and length $rest;
179 |  |  |  |  | if($rest =~ m/^(\w+)$/s) {
180 |  |  |  |  | $rest = $1; #untaint
181 |  |  |  |  | } else {
182 |  |  |  |  | $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") );
183 |  |  |  |  | return;
184 |  |  |  |  | }
185 |  |  |  |  |
186 |  |  |  |  | $self->aside("Noting \"$rest\" as desired output format...\n");
187 |  |  |  |  |
188 |  |  |  |  | # Figure out what class(es) that could actually mean...
189 |  |  |  |  |
190 |  |  |  |  | my @classes;
191 |  |  |  |  | foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
192 |  |  |  |  | # Messy but smart:
193 |  |  |  |  | foreach my $stem (
194 |  |  |  |  | $rest, # Yes, try it first with the given capitalization
195 |  |  |  |  | "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
196 |  |  |  |  |
197 |  |  |  |  | ) {
198 |  |  |  |  | $self->aside("Considering $prefix$stem\n");
199 |  |  |  |  | push @classes, $prefix . $stem;
200 |  |  |  |  | }
201 |  |  |  |  |
202 |  |  |  |  | # Tidier, but misses too much:
203 |  |  |  |  | #push @classes, $prefix . ucfirst(lc($rest));
204 |  |  |  |  | }
205 |  |  |  |  | $self->opt_M_with( join ";", @classes );
206 |  |  |  |  | return;
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | ###########################################################################
210 |  |  |  |  | # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
211 |  |  |  |  |
212 |  |  |  |  | sub run { # to be called by the "perldoc" executable
213 |  |  |  |  | my $class = shift;
214 |  |  |  |  | if(DEBUG > 3) {
215 |  |  |  |  | print "Parameters to $class\->run:\n";
216 |  |  |  |  | my @x = @_;
217 |  |  |  |  | while(@x) {
218 |  |  |  |  | $x[1] = '<undef>' unless defined $x[1];
219 |  |  |  |  | $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
220 |  |  |  |  | print " [$x[0]] => [$x[1]]\n";
221 |  |  |  |  | splice @x,0,2;
222 |  |  |  |  | }
223 |  |  |  |  | print "\n";
224 |  |  |  |  | }
225 |  |  |  |  | return $class -> new(@_) -> process() || 0;
226 |  |  |  |  | }
227 |  |  |  |  |
228 |  |  |  |  | # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
229 |  |  |  |  | ###########################################################################
230 |  |  |  |  |
231 |  |  |  |  | sub new { # yeah, nothing fancy
232 |  |  |  |  | my $class = shift;
233 |  |  |  |  | my $new = bless {@_}, (ref($class) || $class);
234 |  |  |  |  | DEBUG > 1 and print "New $class object $new\n";
235 |  |  |  |  | $new->init();
236 |  |  |  |  | $new;
237 |  |  |  |  | }
238 |  |  |  |  |
239 |  |  |  |  | #..........................................................................
240 |  |  |  |  |
241 |  |  |  |  | sub aside { # If we're in -D or DEBUG mode, say this.
242 |  |  |  |  | my $self = shift;
243 |  |  |  |  | if( DEBUG or $self->opt_D ) {
244 |  |  |  |  | my $out = join( '',
245 |  |  |  |  | DEBUG ? do {
246 |  |  |  |  | my $callsub = (caller(1))[3];
247 |  |  |  |  | my $package = quotemeta(__PACKAGE__ . '::');
248 |  |  |  |  | $callsub =~ s/^$package/'/os;
249 |  |  |  |  | # the o is justified, as $package really won't change.
250 |  |  |  |  | $callsub . ": ";
251 |  |  |  |  | } : '',
252 |  |  |  |  | @_,
253 |  |  |  |  | );
254 |  |  |  |  | if(DEBUG) { print $out } else { print STDERR $out }
255 |  |  |  |  | }
256 |  |  |  |  | return;
257 |  |  |  |  | }
258 |  |  |  |  |
259 |  |  |  |  | #..........................................................................
260 |  |  |  |  |
261 |  |  |  |  | sub usage {
262 |  |  |  |  | my $self = shift;
263 |  |  |  |  | $self->warn( "@_\n" ) if @_;
264 |  |  |  |  |
265 |  |  |  |  | # Erase evidence of previous errors (if any), so exit status is simple.
266 |  |  |  |  | $! = 0;
267 |  |  |  |  |
268 |  |  |  |  | CORE::die( <<EOF );
269 |  |  |  |  | perldoc [options] PageName|ModuleName|ProgramName|URL...
270 |  |  |  |  | perldoc [options] -f BuiltinFunction
271 |  |  |  |  | perldoc [options] -q FAQRegex
272 |  |  |  |  | perldoc [options] -v PerlVariable
273 |  |  |  |  |
274 |  |  |  |  | Options:
275 |  |  |  |  | -h Display this help message
276 |  |  |  |  | -V Report version
277 |  |  |  |  | -r Recursive search (slow)
278 |  |  |  |  | -i Ignore case
279 |  |  |  |  | -t Display pod using pod2text instead of Pod::Man and groff
280 |  |  |  |  | (-t is the default on win32 unless -n is specified)
281 |  |  |  |  | -u Display unformatted pod text
282 |  |  |  |  | -m Display module's file in its entirety
283 |  |  |  |  | -n Specify replacement for groff
284 |  |  |  |  | -l Display the module's file name
285 |  |  |  |  | -F Arguments are file names, not modules
286 |  |  |  |  | -D Verbosely describe what's going on
287 |  |  |  |  | -T Send output to STDOUT without any pager
288 |  |  |  |  | -d output_filename_to_send_to
289 |  |  |  |  | -o output_format_name
290 |  |  |  |  | -M FormatterModuleNameToUse
291 |  |  |  |  | -w formatter_option:option_value
292 |  |  |  |  | -L translation_code Choose doc translation (if any)
293 |  |  |  |  | -X Use index if present (looks for pod.idx at $Config{archlib})
294 |  |  |  |  | -q Search the text of questions (not answers) in perlfaq[1-9]
295 |  |  |  |  | -f Search Perl built-in functions
296 |  |  |  |  | -v Search predefined Perl variables
297 |  |  |  |  |
298 |  |  |  |  | PageName|ModuleName|ProgramName|URL...
299 |  |  |  |  | is the name of a piece of documentation that you want to look at. You
300 |  |  |  |  | may either give a descriptive name of the page (as in the case of
301 |  |  |  |  | `perlfunc') the name of a module, either like `Term::Info' or like
302 |  |  |  |  | `Term/Info', or the name of a program, like `perldoc', or a URL
303 |  |  |  |  | starting with http(s).
304 |  |  |  |  |
305 |  |  |  |  | BuiltinFunction
306 |  |  |  |  | is the name of a perl function. Will extract documentation from
307 |  |  |  |  | `perlfunc' or `perlop'.
308 |  |  |  |  |
309 |  |  |  |  | FAQRegex
310 |  |  |  |  | is a regex. Will search perlfaq[1-9] for and extract any
311 |  |  |  |  | questions that match.
312 |  |  |  |  |
313 |  |  |  |  | Any switches in the PERLDOC environment variable will be used before the
314 |  |  |  |  | command line arguments. The optional pod index file contains a list of
315 |  |  |  |  | filenames, one per line.
316 |  |  |  |  | [Perldoc v$VERSION]
317 |  |  |  |  | EOF
318 |  |  |  |  |
319 |  |  |  |  | }
320 |  |  |  |  |
321 |  |  |  |  | #..........................................................................
322 |  |  |  |  |
323 |  |  |  |  | sub program_name {
324 |  |  |  |  | my( $self ) = @_;
325 |  |  |  |  |
326 |  |  |  |  | if( my $link = readlink( $0 ) ) {
327 |  |  |  |  | $self->debug( "The value in $0 is a symbolic link to $link\n" );
328 |  |  |  |  | }
329 |  |  |  |  |
330 |  |  |  |  | my $basename = basename( $0 );
331 |  |  |  |  |
332 |  |  |  |  | $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" );
333 |  |  |  |  | # possible name forms
334 |  |  |  |  | # perldoc
335 |  |  |  |  | # perldoc-v5.14
336 |  |  |  |  | # perldoc-5.14
337 |  |  |  |  | # perldoc-5.14.2
338 |  |  |  |  | # perlvar # an alias mentioned in Camel 3
339 |  |  |  |  | {
340 |  |  |  |  | my( $untainted ) = $basename =~ m/(
341 |  |  |  |  | \A
342 |  |  |  |  | perl
343 |  |  |  |  | (?: doc | func | faq | help | op | toc | var # Camel 3
344 |  |  |  |  | )
345 |  |  |  |  | (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version
346 |  |  |  |  | (?: \. (?: bat | exe | com ) )? # possible extension
347 |  |  |  |  | \z
348 |  |  |  |  | )
349 |  |  |  |  | /x;
350 |  |  |  |  |
351 |  |  |  |  | $self->debug($untainted);
352 |  |  |  |  | return $untainted if $untainted;
353 |  |  |  |  | }
354 |  |  |  |  |
355 |  |  |  |  | $self->warn(<<"HERE");
356 |  |  |  |  | You called the perldoc command with a name that I didn't recognize.
357 |  |  |  |  | This might mean that someone is tricking you into running a
358 |  |  |  |  | program you don't intend to use, but it also might mean that you
359 |  |  |  |  | created your own link to perldoc. I think your program name is
360 |  |  |  |  | [$basename].
361 |  |  |  |  |
362 |  |  |  |  | I'll allow this if the filename only has [a-zA-Z0-9._-].
363 |  |  |  |  | HERE
364 |  |  |  |  |
365 |  |  |  |  | {
366 |  |  |  |  | my( $untainted ) = $basename =~ m/(
367 |  |  |  |  | \A [a-zA-Z0-9._-]+ \z
368 |  |  |  |  | )/x;
369 |  |  |  |  |
370 |  |  |  |  | $self->debug($untainted);
371 |  |  |  |  | return $untainted if $untainted;
372 |  |  |  |  | }
373 |  |  |  |  |
374 |  |  |  |  | $self->die(<<"HERE");
375 |  |  |  |  | I think that your name for perldoc is potentially unsafe, so I'm
376 |  |  |  |  | going to disallow it. I'd rather you be safe than sorry. If you
377 |  |  |  |  | intended to use the name I'm disallowing, please tell the maintainers
378 |  |  |  |  | about it. Write to:
379 |  |  |  |  |
380 |  |  |  |  | Pod-Perldoc\@rt.cpan.org
381 |  |  |  |  |
382 |  |  |  |  | HERE
383 |  |  |  |  | }
384 |  |  |  |  |
385 |  |  |  |  | #..........................................................................
386 |  |  |  |  |
387 |  |  |  |  | sub usage_brief {
388 |  |  |  |  | my $self = shift;
389 |  |  |  |  | my $program_name = $self->program_name;
390 |  |  |  |  |
391 |  |  |  |  | CORE::die( <<"EOUSAGE" );
392 |  |  |  |  | Usage: $program_name [-hVriDtumFXlT] [-n nroffer_program]
393 |  |  |  |  | [-d output_filename] [-o output_format] [-M FormatterModule]
394 |  |  |  |  | [-w formatter_option:option_value] [-L translation_code]
395 |  |  |  |  | PageName|ModuleName|ProgramName
396 |  |  |  |  |
397 |  |  |  |  | Examples:
398 |  |  |  |  |
399 |  |  |  |  | $program_name -f PerlFunc
400 |  |  |  |  | $program_name -q FAQKeywords
401 |  |  |  |  | $program_name -v PerlVar
402 |  |  |  |  |
403 |  |  |  |  | The -h option prints more help. Also try "$program_name perldoc" to get
404 |  |  |  |  | acquainted with the system. [Perldoc v$VERSION]
405 |  |  |  |  | EOUSAGE
406 |  |  |  |  |
407 |  |  |  |  | }
408 |  |  |  |  |
409 |  |  |  |  | #..........................................................................
410 |  |  |  |  |
411 |  |  |  |  | sub pagers { @{ shift->{'pagers'} } }
412 |  |  |  |  |
413 |  |  |  |  | #..........................................................................
414 |  |  |  |  |
415 |  |  |  |  | sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
416 |  |  |  |  | if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
417 |  |  |  |  | else { return $_[0]{ $_[1] } }
418 |  |  |  |  | }
419 |  |  |  |  | #..........................................................................
420 |  |  |  |  | ###########################################################################
421 |  |  |  |  | #
422 |  |  |  |  | # Init formatter switches, and start it off with __bindir and all that
423 |  |  |  |  | # other stuff that ToMan.pm needs.
424 |  |  |  |  | #
425 |  |  |  |  |
426 |  |  |  |  | sub init {
427 |  |  |  |  | my $self = shift;
428 |  |  |  |  |
429 |  |  |  |  | # Make sure creat()s are neither too much nor too little
430 |  |  |  |  | eval { umask(0077) }; # doubtless someone has no mask
431 |  |  |  |  |
432 |  |  |  |  | $self->{'args'} ||= \@ARGV;
433 |  |  |  |  | $self->{'found'} ||= [];
434 |  |  |  |  | $self->{'temp_file_list'} ||= [];
435 |  |  |  |  |
436 |  |  |  |  |
437 |  |  |  |  | $self->{'target'} = undef;
438 |  |  |  |  |
439 |  |  |  |  | $self->init_formatter_class_list;
440 |  |  |  |  |
441 |  |  |  |  | $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
442 |  |  |  |  | $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
443 |  |  |  |  | $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
444 |  |  |  |  |
445 |  |  |  |  | push @{ $self->{'formatter_switches'} = [] }, (
446 |  |  |  |  | # Yeah, we could use a hashref, but maybe there's some class where options
447 |  |  |  |  | # have to be ordered; so we'll use an arrayref.
448 |  |  |  |  |
449 |  |  |  |  | [ '__bindir' => $self->{'bindir' } ],
450 |  |  |  |  | [ '__pod2man' => $self->{'pod2man'} ],
451 |  |  |  |  | );
452 |  |  |  |  |
453 |  |  |  |  | DEBUG > 3 and printf "Formatter switches now: [%s]\n",
454 |  |  |  |  | join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
455 |  |  |  |  |
456 |  |  |  |  | $self->{'translators'} = [];
457 |  |  |  |  | $self->{'extra_search_dirs'} = [];
458 |  |  |  |  |
459 |  |  |  |  | return;
460 |  |  |  |  | }
461 |  |  |  |  |
462 |  |  |  |  | #..........................................................................
463 |  |  |  |  |
464 |  |  |  |  | sub init_formatter_class_list {
465 |  |  |  |  | my $self = shift;
466 |  |  |  |  | $self->{'formatter_classes'} ||= [];
467 |  |  |  |  |
468 |  |  |  |  | # Remember, no switches have been read yet, when
469 |  |  |  |  | # we've started this routine.
470 |  |  |  |  |
471 |  |  |  |  | $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
472 |  |  |  |  | $self->opt_o_with('text');
473 |  |  |  |  | $self->opt_o_with('man') unless $self->is_mswin32 || $self->is_dos
474 |  |  |  |  | || !($ENV{TERM} && (
475 |  |  |  |  | ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
476 |  |  |  |  | ));
477 |  |  |  |  |
478 |  |  |  |  | return;
479 |  |  |  |  | }
480 |  |  |  |  |
481 |  |  |  |  | #..........................................................................
482 |  |  |  |  |
483 |  |  |  |  | sub process {
484 |  |  |  |  | # if this ever returns, its retval will be used for exit(RETVAL)
485 |  |  |  |  |
486 |  |  |  |  | my $self = shift;
487 |  |  |  |  | DEBUG > 1 and print " Beginning process.\n";
488 |  |  |  |  | DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
489 |  |  |  |  | if(DEBUG > 3) {
490 |  |  |  |  | print "Object contents:\n";
491 |  |  |  |  | my @x = %$self;
492 |  |  |  |  | while(@x) {
493 |  |  |  |  | $x[1] = '<undef>' unless defined $x[1];
494 |  |  |  |  | $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
495 |  |  |  |  | print " [$x[0]] => [$x[1]]\n";
496 |  |  |  |  | splice @x,0,2;
497 |  |  |  |  | }
498 |  |  |  |  | print "\n";
499 |  |  |  |  | }
500 |  |  |  |  |
501 |  |  |  |  | # TODO: make it deal with being invoked as various different things
502 |  |  |  |  | # such as perlfaq".
503 |  |  |  |  |
504 |  |  |  |  | return $self->usage_brief unless @{ $self->{'args'} };
505 |  |  |  |  | $self->pagers_guessing;
506 |  |  |  |  | $self->options_reading;
507 |  |  |  |  | $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
508 |  |  |  |  | $self->drop_privs_maybe;
509 |  |  |  |  | $self->options_processing;
510 |  |  |  |  |
511 |  |  |  |  | # Hm, we have @pages and @found, but we only really act on one
512 |  |  |  |  | # file per call, with the exception of the opt_q hack, and with
513 |  |  |  |  | # -l things
514 |  |  |  |  |
515 |  |  |  |  | $self->aside("\n");
516 |  |  |  |  |
517 |  |  |  |  | my @pages;
518 |  |  |  |  | $self->{'pages'} = \@pages;
519 |  |  |  |  | if( $self->opt_f) { @pages = qw(perlfunc perlop) }
520 |  |  |  |  | elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
521 |  |  |  |  | elsif( $self->opt_v) { @pages = ("perlvar") }
522 |  |  |  |  | else { @pages = @{$self->{'args'}};
523 |  |  |  |  | # @pages = __FILE__
524 |  |  |  |  | # if @pages == 1 and $pages[0] eq 'perldoc';
525 |  |  |  |  | }
526 |  |  |  |  |
527 |  |  |  |  | return $self->usage_brief unless @pages;
528 |  |  |  |  |
529 |  |  |  |  | $self->find_good_formatter_class();
530 |  |  |  |  | $self->formatter_sanity_check();
531 |  |  |  |  |
532 |  |  |  |  | $self->maybe_diddle_INC();
533 |  |  |  |  | # for when we're apparently in a module or extension directory
534 |  |  |  |  |
535 |  |  |  |  | my @found = $self->grand_search_init(\@pages);
536 |  |  |  |  | exit ($self->is_vms ? 98962 : 1) unless @found;
537 |  |  |  |  |
538 |  |  |  |  | if ($self->opt_l and not $self->opt_q ) {
539 |  |  |  |  | DEBUG and print "We're in -l mode, so byebye after this:\n";
540 |  |  |  |  | print join("\n", @found), "\n";
541 |  |  |  |  | return;
542 |  |  |  |  | }
543 |  |  |  |  |
544 |  |  |  |  | $self->tweak_found_pathnames(\@found);
545 |  |  |  |  | $self->assert_closing_stdout;
546 |  |  |  |  | return $self->page_module_file(@found) if $self->opt_m;
547 |  |  |  |  | DEBUG > 2 and print "Found: [@found]\n";
548 |  |  |  |  |
549 |  |  |  |  | return $self->render_and_page(\@found);
550 |  |  |  |  | }
551 |  |  |  |  |
552 |  |  |  |  | #..........................................................................
553 |  |  |  |  | {
554 |  |  |  |  |
555 | 2 | 800ns |  |  | my( %class_seen, %class_loaded );
556 |  |  |  |  | sub find_good_formatter_class {
557 |  |  |  |  | my $self = $_[0];
558 |  |  |  |  | my @class_list = @{ $self->{'formatter_classes'} || [] };
559 |  |  |  |  | $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list;
560 |  |  |  |  |
561 |  |  |  |  | my $good_class_found;
562 |  |  |  |  | foreach my $c (@class_list) {
563 |  |  |  |  | DEBUG > 4 and print "Trying to load $c...\n";
564 |  |  |  |  | if($class_loaded{$c}) {
565 |  |  |  |  | DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
566 |  |  |  |  | $good_class_found = $c;
567 |  |  |  |  | last;
568 |  |  |  |  | }
569 |  |  |  |  |
570 |  |  |  |  | if($class_seen{$c}) {
571 |  |  |  |  | DEBUG > 4 and print
572 |  |  |  |  | "I've tried $c before, and it's no good. Skipping.\n";
573 |  |  |  |  | next;
574 |  |  |  |  | }
575 |  |  |  |  |
576 |  |  |  |  | $class_seen{$c} = 1;
577 |  |  |  |  |
578 |  |  |  |  | if( $c->can('parse_from_file') ) {
579 |  |  |  |  | DEBUG > 4 and print
580 |  |  |  |  | "Interesting, the formatter class $c is already loaded!\n";
581 |  |  |  |  |
582 |  |  |  |  | } elsif(
583 |  |  |  |  | ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2)
584 |  |  |  |  | # the always case-insensitive filesystems
585 |  |  |  |  | and $class_seen{lc("~$c")}++
586 |  |  |  |  | ) {
587 |  |  |  |  | DEBUG > 4 and print
588 |  |  |  |  | "We already used something quite like \"\L$c\E\", so no point using $c\n";
589 |  |  |  |  | # This avoids redefining the package.
590 |  |  |  |  | } else {
591 |  |  |  |  | DEBUG > 4 and print "Trying to eval 'require $c'...\n";
592 |  |  |  |  |
593 |  |  |  |  | local $^W = $^W;
594 |  |  |  |  | if(DEBUG() or $self->opt_D) {
595 |  |  |  |  | # feh, let 'em see it
596 |  |  |  |  | } else {
597 |  |  |  |  | $^W = 0;
598 |  |  |  |  | # The average user just has no reason to be seeing
599 |  |  |  |  | # $^W-suppressible warnings from the the require!
600 |  |  |  |  | }
601 |  |  |  |  |
602 |  |  |  |  | eval "require $c";
603 |  |  |  |  | if($@) {
604 |  |  |  |  | DEBUG > 4 and print "Couldn't load $c: $!\n";
605 |  |  |  |  | next;
606 |  |  |  |  | }
607 |  |  |  |  | }
608 |  |  |  |  |
609 |  |  |  |  | if( $c->can('parse_from_file') ) {
610 |  |  |  |  | DEBUG > 4 and print "Settling on $c\n";
611 |  |  |  |  | my $v = $c->VERSION;
612 |  |  |  |  | $v = ( defined $v and length $v ) ? " version $v" : '';
613 |  |  |  |  | $self->aside("Formatter class $c$v successfully loaded!\n");
614 |  |  |  |  | $good_class_found = $c;
615 |  |  |  |  | last;
616 |  |  |  |  | } else {
617 |  |  |  |  | DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
618 |  |  |  |  | }
619 |  |  |  |  | }
620 |  |  |  |  |
621 |  |  |  |  | $self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" )
622 |  |  |  |  | unless $good_class_found;
623 |  |  |  |  |
624 |  |  |  |  | $self->{'formatter_class'} = $good_class_found;
625 |  |  |  |  | $self->aside("Will format with the class $good_class_found\n");
626 |  |  |  |  |
627 |  |  |  |  | return;
628 |  |  |  |  | }
629 |  |  |  |  |
630 |  |  |  |  | }
631 |  |  |  |  | #..........................................................................
632 |  |  |  |  |
633 |  |  |  |  | sub formatter_sanity_check {
634 |  |  |  |  | my $self = shift;
635 |  |  |  |  | my $formatter_class = $self->{'formatter_class'}
636 |  |  |  |  | || $self->die( "NO FORMATTER CLASS YET!?" );
637 |  |  |  |  |
638 |  |  |  |  | if(!$self->opt_T # so -T can FORCE sending to STDOUT
639 |  |  |  |  | and $formatter_class->can('is_pageable')
640 |  |  |  |  | and !$formatter_class->is_pageable
641 |  |  |  |  | and !$formatter_class->can('page_for_perldoc')
642 |  |  |  |  | ) {
643 |  |  |  |  | my $ext =
644 |  |  |  |  | ($formatter_class->can('output_extension')
645 |  |  |  |  | && $formatter_class->output_extension
646 |  |  |  |  | ) || '';
647 |  |  |  |  | $ext = ".$ext" if length $ext;
648 |  |  |  |  |
649 |  |  |  |  | my $me = $self->program_name;
650 |  |  |  |  | $self->die(
651 |  |  |  |  | "When using Perldoc to format with $formatter_class, you have to\n"
652 |  |  |  |  | . "specify -T or -dsomefile$ext\n"
653 |  |  |  |  | . "See `$me perldoc' for more information on those switches.\n" )
654 |  |  |  |  | ;
655 |  |  |  |  | }
656 |  |  |  |  | }
657 |  |  |  |  |
658 |  |  |  |  | #..........................................................................
659 |  |  |  |  |
660 |  |  |  |  | sub render_and_page {
661 |  |  |  |  | my($self, $found_list) = @_;
662 |  |  |  |  |
663 |  |  |  |  | $self->maybe_generate_dynamic_pod($found_list);
664 |  |  |  |  |
665 |  |  |  |  | my($out, $formatter) = $self->render_findings($found_list);
666 |  |  |  |  |
667 |  |  |  |  | if($self->opt_d) {
668 |  |  |  |  | printf "Perldoc (%s) output saved to %s\n",
669 |  |  |  |  | $self->{'formatter_class'} || ref($self),
670 |  |  |  |  | $out;
671 |  |  |  |  | print "But notice that it's 0 bytes long!\n" unless -s $out;
672 |  |  |  |  |
673 |  |  |  |  |
674 |  |  |  |  | } elsif( # Allow the formatter to "page" itself, if it wants.
675 |  |  |  |  | $formatter->can('page_for_perldoc')
676 |  |  |  |  | and do {
677 |  |  |  |  | $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
678 |  |  |  |  | if( $formatter->page_for_perldoc($out, $self) ) {
679 |  |  |  |  | $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
680 |  |  |  |  | 1;
681 |  |  |  |  | } else {
682 |  |  |  |  | $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
683 |  |  |  |  | '';
684 |  |  |  |  | }
685 |  |  |  |  | }
686 |  |  |  |  | ) {
687 |  |  |  |  | # Do nothing, since the formatter has "paged" it for itself.
688 |  |  |  |  |
689 |  |  |  |  | } else {
690 |  |  |  |  | # Page it normally (internally)
691 |  |  |  |  |
692 |  |  |  |  | if( -s $out ) { # Usual case:
693 |  |  |  |  | $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
694 |  |  |  |  |
695 |  |  |  |  | } else {
696 |  |  |  |  | # Odd case:
697 |  |  |  |  | $self->aside("Skipping $out (from $$found_list[0] "
698 |  |  |  |  | . "via $$self{'formatter_class'}) as it is 0-length.\n");
699 |  |  |  |  |
700 |  |  |  |  | push @{ $self->{'temp_file_list'} }, $out;
701 |  |  |  |  | $self->unlink_if_temp_file($out);
702 |  |  |  |  | }
703 |  |  |  |  | }
704 |  |  |  |  |
705 |  |  |  |  | $self->after_rendering(); # any extra cleanup or whatever
706 |  |  |  |  |
707 |  |  |  |  | return;
708 |  |  |  |  | }
709 |  |  |  |  |
710 |  |  |  |  | #..........................................................................
711 |  |  |  |  |
712 |  |  |  |  | sub options_reading {
713 |  |  |  |  | my $self = shift;
714 |  |  |  |  |
715 |  |  |  |  | if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
716 |  |  |  |  | require Text::ParseWords;
717 |  |  |  |  | $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
718 |  |  |  |  | # Yes, appends to the beginning
719 |  |  |  |  | unshift @{ $self->{'args'} },
720 |  |  |  |  | Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
721 |  |  |  |  | ;
722 |  |  |  |  | DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
723 |  |  |  |  | } else {
724 |  |  |  |  | DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
725 |  |  |  |  | }
726 |  |  |  |  |
727 |  |  |  |  | DEBUG > 1
728 |  |  |  |  | and print " Args right before switch processing: @{$self->{'args'}}\n";
729 |  |  |  |  |
730 |  |  |  |  | Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
731 |  |  |  |  | or return $self->usage;
732 |  |  |  |  |
733 |  |  |  |  | DEBUG > 1
734 |  |  |  |  | and print " Args after switch processing: @{$self->{'args'}}\n";
735 |  |  |  |  |
736 |  |  |  |  | return $self->usage if $self->opt_h;
737 |  |  |  |  |
738 |  |  |  |  | return;
739 |  |  |  |  | }
740 |  |  |  |  |
741 |  |  |  |  | #..........................................................................
742 |  |  |  |  |
743 |  |  |  |  | sub options_processing {
744 |  |  |  |  | my $self = shift;
745 |  |  |  |  |
746 |  |  |  |  | if ($self->opt_X) {
747 |  |  |  |  | my $podidx = "$Config{'archlib'}/pod.idx";
748 |  |  |  |  | $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
749 |  |  |  |  | $self->{'podidx'} = $podidx;
750 |  |  |  |  | }
751 |  |  |  |  |
752 |  |  |  |  | $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
753 |  |  |  |  |
754 |  |  |  |  | $self->options_sanity;
755 |  |  |  |  |
756 |  |  |  |  | # This used to set a default, but that's now moved into any
757 |  |  |  |  | # formatter that cares to have a default.
758 |  |  |  |  | if( $self->opt_n ) {
759 |  |  |  |  | $self->add_formatter_option( '__nroffer' => $self->opt_n );
760 |  |  |  |  | }
761 |  |  |  |  |
762 |  |  |  |  | # Get language from PERLDOC_POD2 environment variable
763 |  |  |  |  | if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) {
764 |  |  |  |  | if ( $ENV{PERLDOC_POD2} eq '1' ) {
765 |  |  |  |  | $self->_elem('opt_L',(split(/\_/, $ENV{LC_ALL} || $ENV{LC_LANG} || $ENV{LANG}))[0] );
766 |  |  |  |  | }
767 |  |  |  |  | else {
768 |  |  |  |  | $self->_elem('opt_L', $ENV{PERLDOC_POD2});
769 |  |  |  |  | }
770 |  |  |  |  | };
771 |  |  |  |  |
772 |  |  |  |  | # Adjust for using translation packages
773 |  |  |  |  | $self->add_translator(split(/\s+/,$self->opt_L)) if $self->opt_L;
774 |  |  |  |  |
775 |  |  |  |  | return;
776 |  |  |  |  | }
777 |  |  |  |  |
778 |  |  |  |  | #..........................................................................
779 |  |  |  |  |
780 |  |  |  |  | sub options_sanity {
781 |  |  |  |  | my $self = shift;
782 |  |  |  |  |
783 |  |  |  |  | # The opts-counting stuff interacts quite badly with
784 |  |  |  |  | # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
785 |  |  |  |  | # set to -t, and I specify -u on the command line, I don't want
786 |  |  |  |  | # to be hectored at that -u and -t don't make sense together.
787 |  |  |  |  |
788 |  |  |  |  | #my $opts = grep $_ && 1, # yes, the count of the set ones
789 |  |  |  |  | # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
790 |  |  |  |  | #;
791 |  |  |  |  | #
792 |  |  |  |  | #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
793 |  |  |  |  |
794 |  |  |  |  |
795 |  |  |  |  | # Any sanity-checking need doing here?
796 |  |  |  |  |
797 |  |  |  |  | # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
798 |  |  |  |  | if( $self->opt_f or $self->opt_q ) {
799 |  |  |  |  | $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
800 |  |  |  |  | $self->warn(
801 |  |  |  |  | "Perldoc is meant for reading one file at a time.\n",
802 |  |  |  |  | "So these parameters are being ignored: ",
803 |  |  |  |  | join(' ', @{$self->{'args'}}),
804 |  |  |  |  | "\n" )
805 |  |  |  |  | if @{$self->{'args'}}
806 |  |  |  |  | }
807 |  |  |  |  | return;
808 |  |  |  |  | }
809 |  |  |  |  |
810 |  |  |  |  | #..........................................................................
811 |  |  |  |  |
812 |  |  |  |  | sub grand_search_init {
813 |  |  |  |  | my($self, $pages, @found) = @_;
814 |  |  |  |  |
815 |  |  |  |  | foreach (@$pages) {
816 |  |  |  |  | if (/^http(s)?:\/\//) {
817 |  |  |  |  | require HTTP::Tiny;
818 |  |  |  |  | require File::Temp;
819 |  |  |  |  | my $response = HTTP::Tiny->new->get($_);
820 |  |  |  |  | if ($response->{success}) {
821 |  |  |  |  | my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
822 |  |  |  |  | $fh->print($response->{content});
823 |  |  |  |  | push @found, $filename;
824 |  |  |  |  | ($self->{podnames}{$filename} =
825 |  |  |  |  | m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN")
826 |  |  |  |  | =~ s/\.P(?:[ML]|OD)\z//;
827 |  |  |  |  | }
828 |  |  |  |  | else {
829 |  |  |  |  | print STDERR "No " .
830 |  |  |  |  | ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
831 |  |  |  |  | }
832 |  |  |  |  | next;
833 |  |  |  |  | }
834 |  |  |  |  | if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
835 |  |  |  |  | my $searchfor = catfile split '::', $_;
836 |  |  |  |  | $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
837 |  |  |  |  | local $_;
838 |  |  |  |  | while (<PODIDX>) {
839 |  |  |  |  | chomp;
840 |  |  |  |  | push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
841 |  |  |  |  | }
842 |  |  |  |  | close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" );
843 |  |  |  |  | next;
844 |  |  |  |  | }
845 |  |  |  |  |
846 |  |  |  |  | $self->aside( "Searching for $_\n" );
847 |  |  |  |  |
848 |  |  |  |  | if ($self->opt_F) {
849 |  |  |  |  | next unless -r;
850 |  |  |  |  | push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_);
851 |  |  |  |  | next;
852 |  |  |  |  | }
853 |  |  |  |  |
854 |  |  |  |  | my @searchdirs;
855 |  |  |  |  |
856 |  |  |  |  | # prepend extra search directories (including language specific)
857 |  |  |  |  | push @searchdirs, @{ $self->{'extra_search_dirs'} };
858 |  |  |  |  |
859 |  |  |  |  | # We must look both in @INC for library modules and in $bindir
860 |  |  |  |  | # for executables, like h2xs or perldoc itself.
861 |  |  |  |  | push @searchdirs, ($self->{'bindir'}, @INC);
862 |  |  |  |  | unless ($self->opt_m) {
863 |  |  |  |  | if ($self->is_vms) {
864 |  |  |  |  | my($i,$trn);
865 |  |  |  |  | for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
866 |  |  |  |  | push(@searchdirs,$trn);
867 |  |  |  |  | }
868 |  |  |  |  | push(@searchdirs,'perl_root:[lib.pods]') # installed pods
869 |  |  |  |  | }
870 |  |  |  |  | else {
871 |  |  |  |  | push(@searchdirs, grep(-d, split($Config{path_sep},
872 |  |  |  |  | $ENV{'PATH'})));
873 |  |  |  |  | }
874 |  |  |  |  | }
875 |  |  |  |  | my @files = $self->searchfor(0,$_,@searchdirs);
876 |  |  |  |  | if (@files) {
877 |  |  |  |  | $self->aside( "Found as @files\n" );
878 |  |  |  |  | }
879 |  |  |  |  | # add "perl" prefix, so "perldoc foo" may find perlfoo.pod
880 |  |  |  |  | elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
881 |  |  |  |  | $self->aside( "Loosely found as @files\n" );
882 |  |  |  |  | }
883 |  |  |  |  | else {
884 |  |  |  |  | # no match, try recursive search
885 |  |  |  |  | @searchdirs = grep(!/^\.\z/s,@INC);
886 |  |  |  |  | @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
887 |  |  |  |  | if (@files) {
888 |  |  |  |  | $self->aside( "Loosely found as @files\n" );
889 |  |  |  |  | }
890 |  |  |  |  | else {
891 |  |  |  |  | print STDERR "No " .
892 |  |  |  |  | ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
893 |  |  |  |  | if ( @{ $self->{'found'} } ) {
894 |  |  |  |  | print STDERR "However, try\n";
895 |  |  |  |  | my $me = $self->program_name;
896 |  |  |  |  | for my $dir (@{ $self->{'found'} }) {
897 |  |  |  |  | opendir(DIR, $dir) or $self->die( "opendir $dir: $!" );
898 |  |  |  |  | while (my $file = readdir(DIR)) {
899 |  |  |  |  | next if ($file =~ /^\./s);
900 |  |  |  |  | $file =~ s/\.(pm|pod)\z//; # XXX: badfs
901 |  |  |  |  | print STDERR "\t$me $_\::$file\n";
902 |  |  |  |  | }
903 |  |  |  |  | closedir(DIR) or $self->die( "closedir $dir: $!" );
904 |  |  |  |  | }
905 |  |  |  |  | }
906 |  |  |  |  | }
907 |  |  |  |  | }
908 |  |  |  |  | push(@found,@files);
909 |  |  |  |  | }
910 |  |  |  |  | return @found;
911 |  |  |  |  | }
912 |  |  |  |  |
913 |  |  |  |  | #..........................................................................
914 |  |  |  |  |
915 |  |  |  |  | sub maybe_generate_dynamic_pod {
916 |  |  |  |  | my($self, $found_things) = @_;
917 |  |  |  |  | my @dynamic_pod;
918 |  |  |  |  |
919 |  |  |  |  | $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
920 |  |  |  |  |
921 |  |  |  |  | $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
922 |  |  |  |  |
923 |  |  |  |  | $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
924 |  |  |  |  |
925 |  |  |  |  | if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) {
926 |  |  |  |  | DEBUG > 4 and print "That's a non-dynamic pod search.\n";
927 |  |  |  |  | } elsif ( @dynamic_pod ) {
928 |  |  |  |  | $self->aside("Hm, I found some Pod from that search!\n");
929 |  |  |  |  | my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
930 |  |  |  |  |
931 |  |  |  |  | push @{ $self->{'temp_file_list'} }, $buffer;
932 |  |  |  |  | # I.e., it MIGHT be deleted at the end.
933 |  |  |  |  |
934 |  |  |  |  | my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v;
935 |  |  |  |  |
936 |  |  |  |  | print $buffd "=over 8\n\n" if $in_list;
937 |  |  |  |  | print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" );
938 |  |  |  |  | print $buffd "=back\n" if $in_list;
939 |  |  |  |  |
940 |  |  |  |  | close $buffd or $self->die( "Can't close $buffer: $!" );
941 |  |  |  |  |
942 |  |  |  |  | @$found_things = $buffer;
943 |  |  |  |  | # Yes, so found_things never has more than one thing in
944 |  |  |  |  | # it, by time we leave here
945 |  |  |  |  |
946 |  |  |  |  | $self->add_formatter_option('__filter_nroff' => 1);
947 |  |  |  |  |
948 |  |  |  |  | } else {
949 |  |  |  |  | @$found_things = ();
950 |  |  |  |  | $self->aside("I found no Pod from that search!\n");
951 |  |  |  |  | }
952 |  |  |  |  |
953 |  |  |  |  | return;
954 |  |  |  |  | }
955 |  |  |  |  |
956 |  |  |  |  | #..........................................................................
957 |  |  |  |  |
958 |  |  |  |  | sub not_dynamic {
959 |  |  |  |  | my ($self,$value) = @_;
960 |  |  |  |  | $self->{__not_dynamic} = $value if @_ == 2;
961 |  |  |  |  | return $self->{__not_dynamic};
962 |  |  |  |  | }
963 |  |  |  |  |
964 |  |  |  |  | #..........................................................................
965 |  |  |  |  |
966 |  |  |  |  | sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
967 |  |  |  |  | my $self = shift;
968 |  |  |  |  | push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
969 |  |  |  |  |
970 |  |  |  |  | DEBUG > 3 and printf "Formatter switches now: [%s]\n",
971 |  |  |  |  | join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
972 |  |  |  |  |
973 |  |  |  |  | return;
974 |  |  |  |  | }
975 |  |  |  |  |
976 |  |  |  |  | #.........................................................................
977 |  |  |  |  |
978 |  |  |  |  | sub new_translator { # $tr = $self->new_translator($lang);
979 |  |  |  |  | my $self = shift;
980 |  |  |  |  | my $lang = shift;
981 |  |  |  |  |
982 |  |  |  |  | my $pack = 'POD2::' . uc($lang);
983 |  |  |  |  | eval "require $pack";
984 |  |  |  |  | if ( !$@ && $pack->can('new') ) {
985 |  |  |  |  | return $pack->new();
986 |  |  |  |  | }
987 |  |  |  |  |
988 |  |  |  |  | eval { require POD2::Base };
989 |  |  |  |  | return if $@;
990 |  |  |  |  |
991 |  |  |  |  | return POD2::Base->new({ lang => $lang });
992 |  |  |  |  | }
993 |  |  |  |  |
994 |  |  |  |  | #.........................................................................
995 |  |  |  |  |
996 |  |  |  |  | sub add_translator { # $self->add_translator($lang);
997 |  |  |  |  | my $self = shift;
998 |  |  |  |  | for my $lang (@_) {
999 |  |  |  |  | my $tr = $self->new_translator($lang);
1000 |  |  |  |  | if ( defined $tr ) {
1001 |  |  |  |  | push @{ $self->{'translators'} }, $tr;
1002 |  |  |  |  | push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
1003 |  |  |  |  |
1004 |  |  |  |  | $self->aside( "translator for '$lang' loaded\n" );
1005 |  |  |  |  | } else {
1006 |  |  |  |  | # non-installed or bad translator package
1007 |  |  |  |  | $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" );
1008 |  |  |  |  | }
1009 |  |  |  |  |
1010 |  |  |  |  | }
1011 |  |  |  |  | return;
1012 |  |  |  |  | }
1013 |  |  |  |  |
1014 |  |  |  |  | #..........................................................................
1015 |  |  |  |  |
1016 |  |  |  |  | sub search_perlvar {
1017 |  |  |  |  | my($self, $found_things, $pod) = @_;
1018 |  |  |  |  |
1019 |  |  |  |  | my $opt = $self->opt_v;
1020 |  |  |  |  |
1021 |  |  |  |  | if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
1022 |  |  |  |  | CORE::die( "'$opt' does not look like a Perl variable\n" );
1023 |  |  |  |  | }
1024 |  |  |  |  |
1025 |  |  |  |  | DEBUG > 2 and print "Search: @$found_things\n";
1026 |  |  |  |  |
1027 |  |  |  |  | my $perlvar = shift @$found_things;
1028 |  |  |  |  | open(PVAR, "<", $perlvar) # "Funk is its own reward"
1029 |  |  |  |  | or $self->die("Can't open $perlvar: $!");
1030 |  |  |  |  |
1031 |  |  |  |  | if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
1032 |  |  |  |  | $opt = '$<I<digits>>';
1033 |  |  |  |  | }
1034 |  |  |  |  | my $search_re = quotemeta($opt);
1035 |  |  |  |  |
1036 |  |  |  |  | DEBUG > 2 and
1037 |  |  |  |  | print "Going to perlvar-scan for $search_re in $perlvar\n";
1038 |  |  |  |  |
1039 |  |  |  |  | # Skip introduction
1040 |  |  |  |  | local $_;
1041 |  |  |  |  | while (<PVAR>) {
1042 |  |  |  |  | last if /^=over 8/;
1043 |  |  |  |  | }
1044 |  |  |  |  |
1045 |  |  |  |  | # Look for our variable
1046 |  |  |  |  | my $found = 0;
1047 |  |  |  |  | my $inheader = 1;
1048 |  |  |  |  | my $inlist = 0;
1049 |  |  |  |  | while (<PVAR>) { # "The Mothership Connection is here!"
1050 |  |  |  |  | last if /^=head2 Error Indicators/;
1051 |  |  |  |  | # \b at the end of $` and friends borks things!
1052 |  |  |  |  | if ( m/^=item\s+$search_re\s/ ) {
1053 |  |  |  |  | $found = 1;
1054 |  |  |  |  | }
1055 |  |  |  |  | elsif (/^=item/) {
1056 |  |  |  |  | last if $found && !$inheader && !$inlist;
1057 |  |  |  |  | }
1058 |  |  |  |  | elsif (!/^\s+$/) { # not a blank line
1059 |  |  |  |  | if ( $found ) {
1060 |  |  |  |  | $inheader = 0; # don't accept more =item (unless inlist)
1061 |  |  |  |  | }
1062 |  |  |  |  | else {
1063 |  |  |  |  | @$pod = (); # reset
1064 |  |  |  |  | $inheader = 1; # start over
1065 |  |  |  |  | next;
1066 |  |  |  |  | }
1067 |  |  |  |  | }
1068 |  |  |  |  |
1069 |  |  |  |  | if (/^=over/) {
1070 |  |  |  |  | ++$inlist;
1071 |  |  |  |  | }
1072 |  |  |  |  | elsif (/^=back/) {
1073 |  |  |  |  | last if $found && !$inheader && !$inlist;
1074 |  |  |  |  | --$inlist;
1075 |  |  |  |  | }
1076 |  |  |  |  | push @$pod, $_;
1077 |  |  |  |  | # ++$found if /^\w/; # found descriptive text
1078 |  |  |  |  | }
1079 |  |  |  |  | @$pod = () unless $found;
1080 |  |  |  |  | if (!@$pod) {
1081 |  |  |  |  | CORE::die( "No documentation for perl variable '$opt' found\n" );
1082 |  |  |  |  | }
1083 |  |  |  |  | close PVAR or $self->die( "Can't open $perlvar: $!" );
1084 |  |  |  |  |
1085 |  |  |  |  | return;
1086 |  |  |  |  | }
1087 |  |  |  |  |
1088 |  |  |  |  | #..........................................................................
1089 |  |  |  |  |
1090 |  |  |  |  | sub search_perlop {
1091 |  |  |  |  | my ($self,$found_things,$pod) = @_;
1092 |  |  |  |  |
1093 |  |  |  |  | $self->not_dynamic( 1 );
1094 |  |  |  |  |
1095 |  |  |  |  | my $perlop = shift @$found_things;
1096 |  |  |  |  | open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" );
1097 |  |  |  |  |
1098 |  |  |  |  | my $paragraph = "";
1099 |  |  |  |  | my $has_text_seen = 0;
1100 |  |  |  |  | my $thing = $self->opt_f;
1101 |  |  |  |  | my $list = 0;
1102 |  |  |  |  |
1103 |  |  |  |  | while( my $line = <PERLOP> ){
1104 |  |  |  |  | if( $paragraph and $line =~ m!^=(?:head|item)! and $paragraph =~ m!X<+\s*\Q$thing\E\s*>+! ){
1105 |  |  |  |  | if( $list ){
1106 |  |  |  |  | $paragraph =~ s!=back.*?\z!!s;
1107 |  |  |  |  | }
1108 |  |  |  |  |
1109 |  |  |  |  | if( $paragraph =~ m!^=item! ){
1110 |  |  |  |  | $paragraph = "=over 8\n\n" . $paragraph . "=back\n";
1111 |  |  |  |  | }
1112 |  |  |  |  |
1113 |  |  |  |  | push @$pod, $paragraph;
1114 |  |  |  |  | $paragraph = "";
1115 |  |  |  |  | $has_text_seen = 0;
1116 |  |  |  |  | $list = 0;
1117 |  |  |  |  | }
1118 |  |  |  |  |
1119 |  |  |  |  | if( $line =~ m!^=over! ){
1120 |  |  |  |  | $list++;
1121 |  |  |  |  | }
1122 |  |  |  |  | elsif( $line =~ m!^=back! ){
1123 |  |  |  |  | $list--;
1124 |  |  |  |  | }
1125 |  |  |  |  |
1126 |  |  |  |  | if( $line =~ m!^=(?:head|item)! and $has_text_seen ){
1127 |  |  |  |  | $paragraph = "";
1128 |  |  |  |  | }
1129 |  |  |  |  | elsif( $line !~ m!^=(?:head|item)! and $line !~ m!^\s*$! and $line !~ m!^\s*X<! ){
1130 |  |  |  |  | $has_text_seen = 1;
1131 |  |  |  |  | }
1132 |  |  |  |  |
1133 |  |  |  |  | $paragraph .= $line;
1134 |  |  |  |  | }
1135 |  |  |  |  |
1136 |  |  |  |  | close PERLOP;
1137 |  |  |  |  |
1138 |  |  |  |  | return;
1139 |  |  |  |  | }
1140 |  |  |  |  |
1141 |  |  |  |  | #..........................................................................
1142 |  |  |  |  |
1143 |  |  |  |  | sub search_perlfunc {
1144 |  |  |  |  | my($self, $found_things, $pod) = @_;
1145 |  |  |  |  |
1146 |  |  |  |  | DEBUG > 2 and print "Search: @$found_things\n";
1147 |  |  |  |  |
1148 |  |  |  |  | my $perlfunc = shift @$found_things;
1149 |  |  |  |  | open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
1150 |  |  |  |  | or $self->die("Can't open $perlfunc: $!");
1151 |  |  |  |  |
1152 |  |  |  |  | # Functions like -r, -e, etc. are listed under `-X'.
1153 |  |  |  |  | my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
1154 |  |  |  |  | ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
1155 |  |  |  |  |
1156 |  |  |  |  | DEBUG > 2 and
1157 |  |  |  |  | print "Going to perlfunc-scan for $search_re in $perlfunc\n";
1158 |  |  |  |  |
1159 |  |  |  |  | my $re = 'Alphabetical Listing of Perl Functions';
1160 |  |  |  |  |
1161 |  |  |  |  | # Check available translator or backup to default (english)
1162 |  |  |  |  | if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
1163 |  |  |  |  | my $tr = $self->{'translators'}->[0];
1164 |  |  |  |  | $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
1165 |  |  |  |  | }
1166 |  |  |  |  |
1167 |  |  |  |  | # Skip introduction
1168 |  |  |  |  | local $_;
1169 |  |  |  |  | while (<PFUNC>) {
1170 |  |  |  |  | last if /^=head2 $re/;
1171 |  |  |  |  | }
1172 |  |  |  |  |
1173 |  |  |  |  | # Look for our function
1174 |  |  |  |  | my $found = 0;
1175 |  |  |  |  | my $inlist = 0;
1176 |  |  |  |  |
1177 |  |  |  |  | my @perlops = qw(m q qq qr qx qw s tr y);
1178 |  |  |  |  |
1179 |  |  |  |  | my @related;
1180 |  |  |  |  | my $related_re;
1181 |  |  |  |  | while (<PFUNC>) { # "The Mothership Connection is here!"
1182 |  |  |  |  | last if( grep{ $self->opt_f eq $_ }@perlops );
1183 |  |  |  |  | if ( m/^=item\s+$search_re\b/ ) {
1184 |  |  |  |  | $found = 1;
1185 |  |  |  |  | }
1186 |  |  |  |  | elsif (@related > 1 and /^=item/) {
1187 |  |  |  |  | $related_re ||= join "|", @related;
1188 |  |  |  |  | if (m/^=item\s+(?:$related_re)\b/) {
1189 |  |  |  |  | $found = 1;
1190 |  |  |  |  | }
1191 |  |  |  |  | else {
1192 |  |  |  |  | last;
1193 |  |  |  |  | }
1194 |  |  |  |  | }
1195 |  |  |  |  | elsif (/^=item/) {
1196 |  |  |  |  | last if $found > 1 and not $inlist;
1197 |  |  |  |  | }
1198 |  |  |  |  | elsif ($found and /^X<[^>]+>/) {
1199 |  |  |  |  | push @related, m/X<([^>]+)>/g;
1200 |  |  |  |  | }
1201 |  |  |  |  | next unless $found;
1202 |  |  |  |  | if (/^=over/) {
1203 |  |  |  |  | ++$inlist;
1204 |  |  |  |  | }
1205 |  |  |  |  | elsif (/^=back/) {
1206 |  |  |  |  | last if $found > 1 and not $inlist;
1207 |  |  |  |  | --$inlist;
1208 |  |  |  |  | }
1209 |  |  |  |  | push @$pod, $_;
1210 |  |  |  |  | ++$found if /^\w/; # found descriptive text
1211 |  |  |  |  | }
1212 |  |  |  |  |
1213 |  |  |  |  | if( !@$pod ){
1214 |  |  |  |  | $self->search_perlop( $found_things, $pod );
1215 |  |  |  |  | }
1216 |  |  |  |  |
1217 |  |  |  |  | if (!@$pod) {
1218 |  |  |  |  | CORE::die( sprintf
1219 |  |  |  |  | "No documentation for perl function '%s' found\n",
1220 |  |  |  |  | $self->opt_f )
1221 |  |  |  |  | ;
1222 |  |  |  |  | }
1223 |  |  |  |  | close PFUNC or $self->die( "Can't open $perlfunc: $!" );
1224 |  |  |  |  |
1225 |  |  |  |  | return;
1226 |  |  |  |  | }
1227 |  |  |  |  |
1228 |  |  |  |  | #..........................................................................
1229 |  |  |  |  |
1230 |  |  |  |  | sub search_perlfaqs {
1231 |  |  |  |  | my( $self, $found_things, $pod) = @_;
1232 |  |  |  |  |
1233 |  |  |  |  | my $found = 0;
1234 |  |  |  |  | my %found_in;
1235 |  |  |  |  | my $search_key = $self->opt_q;
1236 |  |  |  |  |
1237 |  |  |  |  | my $rx = eval { qr/$search_key/ }
1238 |  |  |  |  | or $self->die( <<EOD );
1239 |  |  |  |  | Invalid regular expression '$search_key' given as -q pattern:
1240 |  |  |  |  | $@
1241 |  |  |  |  | Did you mean \\Q$search_key ?
1242 |  |  |  |  |
1243 |  |  |  |  | EOD
1244 |  |  |  |  |
1245 |  |  |  |  | local $_;
1246 |  |  |  |  | foreach my $file (@$found_things) {
1247 |  |  |  |  | $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
1248 |  |  |  |  | open(INFAQ, "<", $file) # XXX 5.6ism
1249 |  |  |  |  | or $self->die( "Can't read-open $file: $!\nAborting" );
1250 |  |  |  |  | while (<INFAQ>) {
1251 |  |  |  |  | if ( m/^=head2\s+.*(?:$search_key)/i ) {
1252 |  |  |  |  | $found = 1;
1253 |  |  |  |  | push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
1254 |  |  |  |  | }
1255 |  |  |  |  | elsif (/^=head[12]/) {
1256 |  |  |  |  | $found = 0;
1257 |  |  |  |  | }
1258 |  |  |  |  | next unless $found;
1259 |  |  |  |  | push @$pod, $_;
1260 |  |  |  |  | }
1261 |  |  |  |  | close(INFAQ);
1262 |  |  |  |  | }
1263 |  |  |  |  | CORE::die("No documentation for perl FAQ keyword '$search_key' found\n")
1264 |  |  |  |  | unless @$pod;
1265 |  |  |  |  |
1266 |  |  |  |  | if ( $self->opt_l ) {
1267 |  |  |  |  | CORE::die((join "\n", keys %found_in) . "\n");
1268 |  |  |  |  | }
1269 |  |  |  |  | return;
1270 |  |  |  |  | }
1271 |  |  |  |  |
1272 |  |  |  |  |
1273 |  |  |  |  | #..........................................................................
1274 |  |  |  |  |
1275 |  |  |  |  | sub render_findings {
1276 |  |  |  |  | # Return the filename to open
1277 |  |  |  |  |
1278 |  |  |  |  | my($self, $found_things) = @_;
1279 |  |  |  |  |
1280 |  |  |  |  | my $formatter_class = $self->{'formatter_class'}
1281 |  |  |  |  | || $self->die( "No formatter class set!?" );
1282 |  |  |  |  | my $formatter = $formatter_class->can('new')
1283 |  |  |  |  | ? $formatter_class->new
1284 |  |  |  |  | : $formatter_class
1285 |  |  |  |  | ;
1286 |  |  |  |  |
1287 |  |  |  |  | if(! @$found_things) {
1288 |  |  |  |  | $self->die( "Nothing found?!" );
1289 |  |  |  |  | # should have been caught before here
1290 |  |  |  |  | } elsif(@$found_things > 1) {
1291 |  |  |  |  | $self->warn(
1292 |  |  |  |  | "Perldoc is only really meant for reading one document at a time.\n",
1293 |  |  |  |  | "So these parameters are being ignored: ",
1294 |  |  |  |  | join(' ', @$found_things[1 .. $#$found_things] ),
1295 |  |  |  |  | "\n" );
1296 |  |  |  |  | }
1297 |  |  |  |  |
1298 |  |  |  |  | my $file = $found_things->[0];
1299 |  |  |  |  |
1300 |  |  |  |  | DEBUG > 3 and printf "Formatter switches now: [%s]\n",
1301 |  |  |  |  | join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
1302 |  |  |  |  |
1303 |  |  |  |  | # Set formatter options:
1304 |  |  |  |  | if( ref $formatter ) {
1305 |  |  |  |  | foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
1306 |  |  |  |  | my($switch, $value, $silent_fail) = @$f;
1307 |  |  |  |  | if( $formatter->can($switch) ) {
1308 |  |  |  |  | eval { $formatter->$switch( defined($value) ? $value : () ) };
1309 |  |  |  |  | $self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" )
1310 |  |  |  |  | if $@;
1311 |  |  |  |  | } else {
1312 |  |  |  |  | if( $silent_fail or $switch =~ m/^__/s ) {
1313 |  |  |  |  | DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
1314 |  |  |  |  | } else {
1315 |  |  |  |  | $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" );
1316 |  |  |  |  | }
1317 |  |  |  |  | }
1318 |  |  |  |  | }
1319 |  |  |  |  | }
1320 |  |  |  |  |
1321 |  |  |  |  | $self->{'output_is_binary'} =
1322 |  |  |  |  | $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
1323 |  |  |  |  |
1324 |  |  |  |  | if( $self->{podnames} and exists $self->{podnames}{$file} and
1325 |  |  |  |  | $formatter->can('name') ) {
1326 |  |  |  |  | $formatter->name($self->{podnames}{$file});
1327 |  |  |  |  | }
1328 |  |  |  |  |
1329 |  |  |  |  | my ($out_fh, $out) = $self->new_output_file(
1330 |  |  |  |  | ( $formatter->can('output_extension') && $formatter->output_extension )
1331 |  |  |  |  | || undef,
1332 |  |  |  |  | $self->useful_filename_bit,
1333 |  |  |  |  | );
1334 |  |  |  |  |
1335 |  |  |  |  | # Now, finally, do the formatting!
1336 |  |  |  |  | {
1337 |  |  |  |  | local $^W = $^W;
1338 |  |  |  |  | if(DEBUG() or $self->opt_D) {
1339 |  |  |  |  | # feh, let 'em see it
1340 |  |  |  |  | } else {
1341 |  |  |  |  | $^W = 0;
1342 |  |  |  |  | # The average user just has no reason to be seeing
1343 |  |  |  |  | # $^W-suppressible warnings from the formatting!
1344 |  |  |  |  | }
1345 |  |  |  |  |
1346 |  |  |  |  | eval { $formatter->parse_from_file( $file, $out_fh ) };
1347 |  |  |  |  | }
1348 |  |  |  |  |
1349 |  |  |  |  | $self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@;
1350 |  |  |  |  | DEBUG > 2 and print "Back from formatting with $formatter_class\n";
1351 |  |  |  |  |
1352 |  |  |  |  | close $out_fh
1353 |  |  |  |  | or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" );
1354 |  |  |  |  | sleep 0; sleep 0; sleep 0;
1355 |  |  |  |  | # Give the system a few timeslices to meditate on the fact
1356 |  |  |  |  | # that the output file does in fact exist and is closed.
1357 |  |  |  |  |
1358 |  |  |  |  | $self->unlink_if_temp_file($file);
1359 |  |  |  |  |
1360 |  |  |  |  | unless( -s $out ) {
1361 |  |  |  |  | if( $formatter->can( 'if_zero_length' ) ) {
1362 |  |  |  |  | # Basically this is just a hook for Pod::Simple::Checker; since
1363 |  |  |  |  | # what other class could /happily/ format an input file with Pod
1364 |  |  |  |  | # as a 0-length output file?
1365 |  |  |  |  | $formatter->if_zero_length( $file, $out, $out_fh );
1366 |  |  |  |  | } else {
1367 |  |  |  |  | $self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" );
1368 |  |  |  |  | }
1369 |  |  |  |  | }
1370 |  |  |  |  |
1371 |  |  |  |  | DEBUG and print "Finished writing to $out.\n";
1372 |  |  |  |  | return($out, $formatter) if wantarray;
1373 |  |  |  |  | return $out;
1374 |  |  |  |  | }
1375 |  |  |  |  |
1376 |  |  |  |  | #..........................................................................
1377 |  |  |  |  |
1378 |  |  |  |  | sub unlink_if_temp_file {
1379 |  |  |  |  | # Unlink the specified file IFF it's in the list of temp files.
1380 |  |  |  |  | # Really only used in the case of -f / -q things when we can
1381 |  |  |  |  | # throw away the dynamically generated source pod file once
1382 |  |  |  |  | # we've formatted it.
1383 |  |  |  |  | #
1384 |  |  |  |  | my($self, $file) = @_;
1385 |  |  |  |  | return unless defined $file and length $file;
1386 |  |  |  |  |
1387 |  |  |  |  | my $temp_file_list = $self->{'temp_file_list'} || return;
1388 |  |  |  |  | if(grep $_ eq $file, @$temp_file_list) {
1389 |  |  |  |  | $self->aside("Unlinking $file\n");
1390 |  |  |  |  | unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" );
1391 |  |  |  |  | } else {
1392 |  |  |  |  | DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1393 |  |  |  |  | }
1394 |  |  |  |  | return;
1395 |  |  |  |  | }
1396 |  |  |  |  |
1397 |  |  |  |  | #..........................................................................
1398 |  |  |  |  |
1399 |  |  |  |  |
1400 |  |  |  |  | sub after_rendering {
1401 |  |  |  |  | my $self = $_[0];
1402 |  |  |  |  | $self->after_rendering_VMS if $self->is_vms;
1403 |  |  |  |  | $self->after_rendering_MSWin32 if $self->is_mswin32;
1404 |  |  |  |  | $self->after_rendering_Dos if $self->is_dos;
1405 |  |  |  |  | $self->after_rendering_OS2 if $self->is_os2;
1406 |  |  |  |  | return;
1407 |  |  |  |  | }
1408 |  |  |  |  |
1409 |  |  |  |  | sub after_rendering_VMS { return }
1410 |  |  |  |  | sub after_rendering_Dos { return }
1411 |  |  |  |  | sub after_rendering_OS2 { return }
1412 |  |  |  |  | sub after_rendering_MSWin32 { return }
1413 |  |  |  |  |
1414 |  |  |  |  | #..........................................................................
1415 |  |  |  |  | # : : : : : : : : :
1416 |  |  |  |  | #..........................................................................
1417 |  |  |  |  |
1418 |  |  |  |  | sub minus_f_nocase { # i.e., do like -f, but without regard to case
1419 |  |  |  |  |
1420 |  |  |  |  | my($self, $dir, $file) = @_;
1421 |  |  |  |  | my $path = catfile($dir,$file);
1422 |  |  |  |  | return $path if -f $path and -r _;
1423 |  |  |  |  |
1424 |  |  |  |  | if(!$self->opt_i
1425 |  |  |  |  | or $self->is_vms or $self->is_mswin32
1426 |  |  |  |  | or $self->is_dos or $self->is_os2
1427 |  |  |  |  | ) {
1428 |  |  |  |  | # On a case-forgiving file system, or if case is important,
1429 |  |  |  |  | # that is it, all we can do.
1430 |  |  |  |  | $self->warn( "Ignored $path: unreadable\n" ) if -f _;
1431 |  |  |  |  | return '';
1432 |  |  |  |  | }
1433 |  |  |  |  |
1434 |  |  |  |  | local *DIR;
1435 |  |  |  |  | my @p = ($dir);
1436 |  |  |  |  | my($p,$cip);
1437 |  |  |  |  | foreach $p (splitdir $file){
1438 |  |  |  |  | my $try = catfile @p, $p;
1439 |  |  |  |  | $self->aside("Scrutinizing $try...\n");
1440 |  |  |  |  | stat $try;
1441 |  |  |  |  | if (-d _) {
1442 |  |  |  |  | push @p, $p;
1443 |  |  |  |  | if ( $p eq $self->{'target'} ) {
1444 |  |  |  |  | my $tmp_path = catfile @p;
1445 |  |  |  |  | my $path_f = 0;
1446 |  |  |  |  | for (@{ $self->{'found'} }) {
1447 |  |  |  |  | $path_f = 1 if $_ eq $tmp_path;
1448 |  |  |  |  | }
1449 |  |  |  |  | push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1450 |  |  |  |  | $self->aside( "Found as $tmp_path but directory\n" );
1451 |  |  |  |  | }
1452 |  |  |  |  | }
1453 |  |  |  |  | elsif (-f _ && -r _ && lc($try) eq lc($path)) {
1454 |  |  |  |  | return $try;
1455 |  |  |  |  | }
1456 |  |  |  |  | elsif (-f _) {
1457 |  |  |  |  | $self->warn( "Ignored $try: unreadable or file/dir mismatch\n" );
1458 |  |  |  |  | }
1459 |  |  |  |  | elsif (-d catdir(@p)) { # at least we see the containing directory!
1460 |  |  |  |  | my $found = 0;
1461 |  |  |  |  | my $lcp = lc $p;
1462 |  |  |  |  | my $p_dirspec = catdir(@p);
1463 |  |  |  |  | opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" );
1464 |  |  |  |  | while(defined( $cip = readdir(DIR) )) {
1465 |  |  |  |  | if (lc $cip eq $lcp){
1466 |  |  |  |  | $found++;
1467 |  |  |  |  | last; # XXX stop at the first? what if there's others?
1468 |  |  |  |  | }
1469 |  |  |  |  | }
1470 |  |  |  |  | closedir DIR or $self->die( "closedir $p_dirspec: $!" );
1471 |  |  |  |  | return "" unless $found;
1472 |  |  |  |  |
1473 |  |  |  |  | push @p, $cip;
1474 |  |  |  |  | my $p_filespec = catfile(@p);
1475 |  |  |  |  | return $p_filespec if -f $p_filespec and -r _;
1476 |  |  |  |  | $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _;
1477 |  |  |  |  | }
1478 |  |  |  |  | }
1479 |  |  |  |  | return "";
1480 |  |  |  |  | }
1481 |  |  |  |  |
1482 |  |  |  |  | #..........................................................................
1483 |  |  |  |  |
1484 |  |  |  |  | sub pagers_guessing {
1485 |  |  |  |  | my $self = shift;
1486 |  |  |  |  |
1487 |  |  |  |  | my @pagers;
1488 |  |  |  |  | push @pagers, $self->pagers;
1489 |  |  |  |  | $self->{'pagers'} = \@pagers;
1490 |  |  |  |  |
1491 |  |  |  |  | if ($self->is_mswin32) {
1492 |  |  |  |  | push @pagers, qw( more< less notepad );
1493 |  |  |  |  | unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1494 |  |  |  |  | }
1495 |  |  |  |  | elsif ($self->is_vms) {
1496 |  |  |  |  | push @pagers, qw( most more less type/page );
1497 |  |  |  |  | }
1498 |  |  |  |  | elsif ($self->is_dos) {
1499 |  |  |  |  | push @pagers, qw( less.exe more.com< );
1500 |  |  |  |  | unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1501 |  |  |  |  | }
1502 |  |  |  |  | else {
1503 |  |  |  |  | if ($self->is_os2) {
1504 |  |  |  |  | unshift @pagers, 'less', 'cmd /c more <';
1505 |  |  |  |  | }
1506 |  |  |  |  | push @pagers, qw( more less pg view cat );
1507 |  |  |  |  | unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER};
1508 |  |  |  |  | }
1509 |  |  |  |  |
1510 |  |  |  |  | if ($self->is_cygwin) {
1511 |  |  |  |  | if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
1512 |  |  |  |  | unshift @pagers, '/usr/bin/less -isrR';
1513 |  |  |  |  | unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1514 |  |  |  |  | }
1515 |  |  |  |  | }
1516 |  |  |  |  |
1517 |  |  |  |  | unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER};
1518 |  |  |  |  |
1519 |  |  |  |  | return;
1520 |  |  |  |  | }
1521 |  |  |  |  |
1522 |  |  |  |  | #..........................................................................
1523 |  |  |  |  |
1524 |  |  |  |  | sub page_module_file {
1525 |  |  |  |  | my($self, @found) = @_;
1526 |  |  |  |  |
1527 |  |  |  |  | # Security note:
1528 |  |  |  |  | # Don't ever just pass this off to anything like MSWin's "start.exe",
1529 |  |  |  |  | # since we might be calling on a .pl file, and we wouldn't want that
1530 |  |  |  |  | # to actually /execute/ the file that we just want to page thru!
1531 |  |  |  |  | # Also a consideration if one were to use a web browser as a pager;
1532 |  |  |  |  | # doing so could trigger the browser's MIME mapping for whatever
1533 |  |  |  |  | # it thinks .pm/.pl/whatever is. Probably just a (useless and
1534 |  |  |  |  | # annoying) "Save as..." dialog, but potentially executing the file
1535 |  |  |  |  | # in question -- particularly in the case of MSIE and it's, ahem,
1536 |  |  |  |  | # occasionally hazy distinction between OS-local extension
1537 |  |  |  |  | # associations, and browser-specific MIME mappings.
1538 |  |  |  |  |
1539 |  |  |  |  | if(@found > 1) {
1540 |  |  |  |  | $self->warn(
1541 |  |  |  |  | "Perldoc is only really meant for reading one document at a time.\n" .
1542 |  |  |  |  | "So these files are being ignored: " .
1543 |  |  |  |  | join(' ', @found[1 .. $#found] ) .
1544 |  |  |  |  | "\n" )
1545 |  |  |  |  | }
1546 |  |  |  |  |
1547 |  |  |  |  | return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers);
1548 |  |  |  |  |
1549 |  |  |  |  | }
1550 |  |  |  |  |
1551 |  |  |  |  | #..........................................................................
1552 |  |  |  |  |
1553 |  |  |  |  | sub check_file {
1554 |  |  |  |  | my($self, $dir, $file) = @_;
1555 |  |  |  |  |
1556 |  |  |  |  | unless( ref $self ) {
1557 |  |  |  |  | # Should never get called:
1558 |  |  |  |  | $Carp::Verbose = 1;
1559 |  |  |  |  | require Carp;
1560 |  |  |  |  | Carp::croak( join '',
1561 |  |  |  |  | "Crazy ", __PACKAGE__, " error:\n",
1562 |  |  |  |  | "check_file must be an object_method!\n",
1563 |  |  |  |  | "Aborting"
1564 |  |  |  |  | );
1565 |  |  |  |  | }
1566 |  |  |  |  |
1567 |  |  |  |  | if(length $dir and not -d $dir) {
1568 |  |  |  |  | DEBUG > 3 and print " No dir $dir -- skipping.\n";
1569 |  |  |  |  | return "";
1570 |  |  |  |  | }
1571 |  |  |  |  |
1572 |  |  |  |  | my $path = $self->minus_f_nocase($dir,$file);
1573 |  |  |  |  | if( length $path and ($self->opt_m ? $self->isprintable($path)
1574 |  |  |  |  | : $self->containspod($path)) ) {
1575 |  |  |  |  | DEBUG > 3 and print
1576 |  |  |  |  | " The file $path indeed looks promising!\n";
1577 |  |  |  |  | return $path;
1578 |  |  |  |  | }
1579 |  |  |  |  | DEBUG > 3 and print " No good: $file in $dir\n";
1580 |  |  |  |  |
1581 |  |  |  |  | return "";
1582 |  |  |  |  | }
1583 |  |  |  |  |
1584 |  |  |  |  | sub isprintable {
1585 |  |  |  |  | my($self, $file, $readit) = @_;
1586 |  |  |  |  | my $size= 1024;
1587 |  |  |  |  | my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc.
1588 |  |  |  |  |
1589 |  |  |  |  | return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i;
1590 |  |  |  |  |
1591 |  |  |  |  | my $data;
1592 |  |  |  |  | local($_);
1593 |  |  |  |  | open(TEST,"<", $file) or $self->die( "Can't open $file: $!" );
1594 |  |  |  |  | read TEST, $data, $size;
1595 |  |  |  |  | close TEST;
1596 |  |  |  |  | $size= length($data);
1597 |  |  |  |  | $data =~ tr/\x09-\x0D\x20-\x7E//d;
1598 |  |  |  |  | return length($data) <= $size*$maxunprintfrac;
1599 |  |  |  |  | }
1600 |  |  |  |  |
1601 |  |  |  |  | #..........................................................................
1602 |  |  |  |  |
1603 |  |  |  |  | sub containspod {
1604 |  |  |  |  | my($self, $file, $readit) = @_;
1605 |  |  |  |  | return 1 if !$readit && $file =~ /\.pod\z/i;
1606 |  |  |  |  |
1607 |  |  |  |  |
1608 |  |  |  |  | # Under cygwin the /usr/bin/perl is legal executable, but
1609 |  |  |  |  | # you cannot open a file with that name. It must be spelled
1610 |  |  |  |  | # out as "/usr/bin/perl.exe".
1611 |  |  |  |  | #
1612 |  |  |  |  | # The following if-case under cygwin prevents error
1613 |  |  |  |  | #
1614 |  |  |  |  | # $ perldoc perl
1615 |  |  |  |  | # Cannot open /usr/bin/perl: no such file or directory
1616 |  |  |  |  | #
1617 |  |  |  |  | # This would work though
1618 |  |  |  |  | #
1619 |  |  |  |  | # $ perldoc perl.pod
1620 |  |  |  |  |
1621 |  |  |  |  | if ( $self->is_cygwin and -x $file and -f "$file.exe" )
1622 |  |  |  |  | {
1623 |  |  |  |  | $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D;
1624 |  |  |  |  | return 0;
1625 |  |  |  |  | }
1626 |  |  |  |  |
1627 |  |  |  |  | local($_);
1628 |  |  |  |  | open(TEST,"<", $file) or $self->die( "Can't open $file: $!" ); # XXX 5.6ism
1629 |  |  |  |  | while (<TEST>) {
1630 |  |  |  |  | if (/^=head/) {
1631 |  |  |  |  | close(TEST) or $self->die( "Can't close $file: $!" );
1632 |  |  |  |  | return 1;
1633 |  |  |  |  | }
1634 |  |  |  |  | }
1635 |  |  |  |  | close(TEST) or $self->die( "Can't close $file: $!" );
1636 |  |  |  |  | return 0;
1637 |  |  |  |  | }
1638 |  |  |  |  |
1639 |  |  |  |  | #..........................................................................
1640 |  |  |  |  |
1641 |  |  |  |  | sub maybe_diddle_INC {
1642 |  |  |  |  | my $self = shift;
1643 |  |  |  |  |
1644 |  |  |  |  | # Does this look like a module or extension directory?
1645 |  |  |  |  |
1646 |  |  |  |  | if (-f "Makefile.PL" || -f "Build.PL") {
1647 |  |  |  |  |
1648 |  |  |  |  | # Add "." and "lib" to @INC (if they exist)
1649 |  |  |  |  | eval q{ use lib qw(. lib); 1; } or $self->die;
1650 |  |  |  |  |
1651 |  |  |  |  | # don't add if superuser
1652 |  |  |  |  | if ($< && $> && -d "blib") { # don't be looking too hard now!
1653 |  |  |  |  | eval q{ use blib; 1 };
1654 |  |  |  |  | $self->warn( $@ ) if $@ && $self->opt_D;
1655 |  |  |  |  | }
1656 |  |  |  |  | }
1657 |  |  |  |  |
1658 |  |  |  |  | return;
1659 |  |  |  |  | }
1660 |  |  |  |  |
1661 |  |  |  |  | #..........................................................................
1662 |  |  |  |  |
1663 |  |  |  |  | sub new_output_file {
1664 |  |  |  |  | my $self = shift;
1665 |  |  |  |  | my $outspec = $self->opt_d; # Yes, -d overrides all else!
1666 |  |  |  |  | # So don't call this twice per format-job!
1667 |  |  |  |  |
1668 |  |  |  |  | return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1669 |  |  |  |  |
1670 |  |  |  |  | # Otherwise open a write-handle on opt_d!f
1671 |  |  |  |  |
1672 |  |  |  |  | my $fh;
1673 |  |  |  |  | # If we are running before perl5.6.0, we can't autovivify
1674 |  |  |  |  | if ($^V < 5.006) {
1675 |  |  |  |  | require Symbol;
1676 |  |  |  |  | $fh = Symbol::gensym();
1677 |  |  |  |  | }
1678 |  |  |  |  | DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1679 |  |  |  |  | $self->die( "Can't write-open $outspec: $!" )
1680 |  |  |  |  | unless open($fh, ">", $outspec); # XXX 5.6ism
1681 |  |  |  |  |
1682 |  |  |  |  | DEBUG > 3 and print "Successfully opened $outspec\n";
1683 |  |  |  |  | binmode($fh) if $self->{'output_is_binary'};
1684 |  |  |  |  | return($fh, $outspec);
1685 |  |  |  |  | }
1686 |  |  |  |  |
1687 |  |  |  |  | #..........................................................................
1688 |  |  |  |  |
1689 |  |  |  |  | sub useful_filename_bit {
1690 |  |  |  |  | # This tries to provide a meaningful bit of text to do with the query,
1691 |  |  |  |  | # such as can be used in naming the file -- since if we're going to be
1692 |  |  |  |  | # opening windows on temp files (as a "pager" may well do!) then it's
1693 |  |  |  |  | # better if the temp file's name (which may well be used as the window
1694 |  |  |  |  | # title) isn't ALL just random garbage!
1695 |  |  |  |  | # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1696 |  |  |  |  | # name than "perldoc_2371981429". So this routine is what tries to
1697 |  |  |  |  | # provide the "LWPSimple" bit.
1698 |  |  |  |  | #
1699 |  |  |  |  | my $self = shift;
1700 |  |  |  |  | my $pages = $self->{'pages'} || return undef;
1701 |  |  |  |  | return undef unless @$pages;
1702 |  |  |  |  |
1703 |  |  |  |  | my $chunk = $pages->[0];
1704 |  |  |  |  | return undef unless defined $chunk;
1705 |  |  |  |  | $chunk =~ s/:://g;
1706 |  |  |  |  | $chunk =~ s/\.\w+$//g; # strip any extension
1707 |  |  |  |  | if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1708 |  |  |  |  | $chunk = $1;
1709 |  |  |  |  | } else {
1710 |  |  |  |  | return undef;
1711 |  |  |  |  | }
1712 |  |  |  |  | $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1713 |  |  |  |  | $chunk = substr($chunk, -10) if length($chunk) > 10;
1714 |  |  |  |  | return $chunk;
1715 |  |  |  |  | }
1716 |  |  |  |  |
1717 |  |  |  |  | #..........................................................................
1718 |  |  |  |  |
1719 |  |  |  |  | sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1720 |  |  |  |  | my $self = shift;
1721 |  |  |  |  |
1722 |  |  |  |  | ++$Temp_Files_Created;
1723 |  |  |  |  |
1724 |  |  |  |  | require File::Temp;
1725 |  |  |  |  | return File::Temp::tempfile(UNLINK => 1);
1726 |  |  |  |  | }
1727 |  |  |  |  |
1728 |  |  |  |  | #..........................................................................
1729 |  |  |  |  |
1730 |  |  |  |  | sub page { # apply a pager to the output file
1731 |  |  |  |  | my ($self, $output, $output_to_stdout, @pagers) = @_;
1732 |  |  |  |  | if ($output_to_stdout) {
1733 |  |  |  |  | $self->aside("Sending unpaged output to STDOUT.\n");
1734 |  |  |  |  | open(TMP, "<", $output) or $self->die( "Can't open $output: $!" ); # XXX 5.6ism
1735 |  |  |  |  | local $_;
1736 |  |  |  |  | while (<TMP>) {
1737 |  |  |  |  | print or $self->die( "Can't print to stdout: $!" );
1738 |  |  |  |  | }
1739 |  |  |  |  | close TMP or $self->die( "Can't close while $output: $!" );
1740 |  |  |  |  | $self->unlink_if_temp_file($output);
1741 |  |  |  |  | } else {
1742 |  |  |  |  | # On VMS, quoting prevents logical expansion, and temp files with no
1743 |  |  |  |  | # extension get the wrong default extension (such as .LIS for TYPE)
1744 |  |  |  |  |
1745 |  |  |  |  | $output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms;
1746 |  |  |  |  |
1747 |  |  |  |  | $output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos;
1748 |  |  |  |  | # Altho "/" under MSWin is in theory good as a pathsep,
1749 |  |  |  |  | # many many corners of the OS don't like it. So we
1750 |  |  |  |  | # have to force it to be "\" to make everyone happy.
1751 |  |  |  |  |
1752 |  |  |  |  | foreach my $pager (@pagers) {
1753 |  |  |  |  | $self->aside("About to try calling $pager $output\n");
1754 |  |  |  |  | if ($self->is_vms) {
1755 |  |  |  |  | last if system("$pager $output") == 0;
1756 |  |  |  |  | } else {
1757 |  |  |  |  | last if system("$pager \"$output\"") == 0;
1758 |  |  |  |  | }
1759 |  |  |  |  | }
1760 |  |  |  |  | }
1761 |  |  |  |  | return;
1762 |  |  |  |  | }
1763 |  |  |  |  |
1764 |  |  |  |  | #..........................................................................
1765 |  |  |  |  |
1766 |  |  |  |  | sub searchfor {
1767 |  |  |  |  | my($self, $recurse,$s,@dirs) = @_;
1768 |  |  |  |  | $s =~ s!::!/!g;
1769 |  |  |  |  | $s = VMS::Filespec::unixify($s) if $self->is_vms;
1770 |  |  |  |  | return $s if -f $s && $self->containspod($s);
1771 |  |  |  |  | $self->aside( "Looking for $s in @dirs\n" );
1772 |  |  |  |  | my $ret;
1773 |  |  |  |  | my $i;
1774 |  |  |  |  | my $dir;
1775 |  |  |  |  | $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1776 |  |  |  |  | for ($i=0; $i<@dirs; $i++) {
1777 |  |  |  |  | $dir = $dirs[$i];
1778 |  |  |  |  | next unless -d $dir;
1779 |  |  |  |  | ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms;
1780 |  |  |  |  | if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1781 |  |  |  |  | or ( $ret = $self->check_file($dir,"$s.pm"))
1782 |  |  |  |  | or ( $ret = $self->check_file($dir,$s))
1783 |  |  |  |  | or ( $self->is_vms and
1784 |  |  |  |  | $ret = $self->check_file($dir,"$s.com"))
1785 |  |  |  |  | or ( $self->is_os2 and
1786 |  |  |  |  | $ret = $self->check_file($dir,"$s.cmd"))
1787 |  |  |  |  | or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and
1788 |  |  |  |  | $ret = $self->check_file($dir,"$s.bat"))
1789 |  |  |  |  | or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1790 |  |  |  |  | or ( $ret = $self->check_file("$dir/pod",$s))
1791 |  |  |  |  | or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1792 |  |  |  |  | or ( $ret = $self->check_file("$dir/pods",$s))
1793 |  |  |  |  | ) {
1794 |  |  |  |  | DEBUG > 1 and print " Found $ret\n";
1795 |  |  |  |  | return $ret;
1796 |  |  |  |  | }
1797 |  |  |  |  |
1798 |  |  |  |  | if ($recurse) {
1799 |  |  |  |  | opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" );
1800 |  |  |  |  | my @newdirs = map catfile($dir, $_), grep {
1801 |  |  |  |  | not /^\.\.?\z/s and
1802 |  |  |  |  | not /^auto\z/s and # save time! don't search auto dirs
1803 |  |  |  |  | -d catfile($dir, $_)
1804 |  |  |  |  | } readdir D;
1805 |  |  |  |  | closedir(D) or $self->die( "Can't closedir $dir: $!" );
1806 |  |  |  |  | next unless @newdirs;
1807 |  |  |  |  | # what a wicked map!
1808 |  |  |  |  | @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms;
1809 |  |  |  |  | $self->aside( "Also looking in @newdirs\n" );
1810 |  |  |  |  | push(@dirs,@newdirs);
1811 |  |  |  |  | }
1812 |  |  |  |  | }
1813 |  |  |  |  | return ();
1814 |  |  |  |  | }
1815 |  |  |  |  |
1816 |  |  |  |  | #..........................................................................
1817 |  |  |  |  | {
1818 | 2 | 400ns |  |  | my $already_asserted;
1819 |  |  |  |  | sub assert_closing_stdout {
1820 |  |  |  |  | my $self = shift;
1821 |  |  |  |  |
1822 |  |  |  |  | return if $already_asserted;
1823 |  |  |  |  |
1824 |  |  |  |  | eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~;
1825 |  |  |  |  | # What for? to let the pager know that nothing more will come?
1826 |  |  |  |  |
1827 |  |  |  |  | $self->die( $@ ) if $@;
1828 |  |  |  |  | $already_asserted = 1;
1829 |  |  |  |  | return;
1830 |  |  |  |  | }
1831 |  |  |  |  | }
1832 |  |  |  |  |
1833 |  |  |  |  | #..........................................................................
1834 |  |  |  |  |
1835 |  |  |  |  | sub tweak_found_pathnames {
1836 |  |  |  |  | my($self, $found) = @_;
1837 |  |  |  |  | if ($self->is_mswin32) {
1838 |  |  |  |  | foreach (@$found) { s,/,\\,g }
1839 |  |  |  |  | }
1840 |  |  |  |  | foreach (@$found) { s,',\\',g } # RT 37347
1841 |  |  |  |  | return;
1842 |  |  |  |  | }
1843 |  |  |  |  |
1844 |  |  |  |  | #..........................................................................
1845 |  |  |  |  | # : : : : : : : : :
1846 |  |  |  |  | #..........................................................................
1847 |  |  |  |  |
1848 |  |  |  |  | sub am_taint_checking {
1849 |  |  |  |  | my $self = shift;
1850 |  |  |  |  | $self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way
1851 |  |  |  |  | my($k,$v) = each %ENV;
1852 |  |  |  |  | return is_tainted($v);
1853 |  |  |  |  | }
1854 |  |  |  |  |
1855 |  |  |  |  | #..........................................................................
1856 |  |  |  |  |
1857 |  |  |  |  | sub is_tainted { # just a function
1858 |  |  |  |  | my $arg = shift;
1859 |  |  |  |  | my $nada = substr($arg, 0, 0); # zero-length!
1860 |  |  |  |  | local $@; # preserve the caller's version of $@
1861 |  |  |  |  | eval { eval "# $nada" };
1862 |  |  |  |  | return length($@) != 0;
1863 |  |  |  |  | }
1864 |  |  |  |  |
1865 |  |  |  |  | #..........................................................................
1866 |  |  |  |  |
1867 |  |  |  |  | sub drop_privs_maybe {
1868 |  |  |  |  | my $self = shift;
1869 |  |  |  |  |
1870 |  |  |  |  | # Attempt to drop privs if we should be tainting and aren't
1871 |  |  |  |  | if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos
1872 |  |  |  |  | || $self->is_os2
1873 |  |  |  |  | )
1874 |  |  |  |  | && ($> == 0 || $< == 0)
1875 |  |  |  |  | && !$self->am_taint_checking()
1876 |  |  |  |  | ) {
1877 |  |  |  |  | my $id = eval { getpwnam("nobody") };
1878 |  |  |  |  | $id = eval { getpwnam("nouser") } unless defined $id;
1879 |  |  |  |  | $id = -2 unless defined $id;
1880 |  |  |  |  | #
1881 |  |  |  |  | # According to Stevens' APUE and various
1882 |  |  |  |  | # (BSD, Solaris, HP-UX) man pages, setting
1883 |  |  |  |  | # the real uid first and effective uid second
1884 |  |  |  |  | # is the way to go if one wants to drop privileges,
1885 |  |  |  |  | # because if one changes into an effective uid of
1886 |  |  |  |  | # non-zero, one cannot change the real uid any more.
1887 |  |  |  |  | #
1888 |  |  |  |  | # Actually, it gets even messier. There is
1889 |  |  |  |  | # a third uid, called the saved uid, and as
1890 |  |  |  |  | # long as that is zero, one can get back to
1891 |  |  |  |  | # uid of zero. Setting the real-effective *twice*
1892 |  |  |  |  | # helps in *most* systems (FreeBSD and Solaris)
1893 |  |  |  |  | # but apparently in HP-UX even this doesn't help:
1894 |  |  |  |  | # the saved uid stays zero (apparently the only way
1895 |  |  |  |  | # in HP-UX to change saved uid is to call setuid()
1896 |  |  |  |  | # when the effective uid is zero).
1897 |  |  |  |  | #
1898 |  |  |  |  | eval {
1899 |  |  |  |  | $< = $id; # real uid
1900 |  |  |  |  | $> = $id; # effective uid
1901 |  |  |  |  | $< = $id; # real uid
1902 |  |  |  |  | $> = $id; # effective uid
1903 |  |  |  |  | };
1904 |  |  |  |  | if( !$@ && $< && $> ) {
1905 |  |  |  |  | DEBUG and print "OK, I dropped privileges.\n";
1906 |  |  |  |  | } elsif( $self->opt_U ) {
1907 |  |  |  |  | DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
1908 |  |  |  |  | } else {
1909 |  |  |  |  | DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
1910 |  |  |  |  | # We used to die here; but that seemed pointless.
1911 |  |  |  |  | }
1912 |  |  |  |  | }
1913 |  |  |  |  | return;
1914 |  |  |  |  | }
1915 |  |  |  |  |
1916 |  |  |  |  | #..........................................................................
1917 |  |  |  |  |
1918 | 1 | 9µs |  |  | 1;
1919 |  |  |  |  |
1920 |  |  |  |  | __END__
|  |  |  |  | # spent 19µs within Pod::Perldoc::CORE:fteexec which was called: # once (19µs+0s) by PONAPI::CLI::Command::manual::BEGIN@9 at line 82 sub Pod::Perldoc::CORE:fteexec; # opcode
|  |  |  |  | # spent 1µs within Pod::Perldoc::CORE:match which was called 2 times, avg 550ns/call: # once (800ns+0s) by Pod::Perldoc::BEGIN@64 at line 71 # once (300ns+0s) by Pod::Perldoc::BEGIN@19 at line 21 sub Pod::Perldoc::CORE:match; # opcode