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