← 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
StatementsExecuted 79 statements in 8.55ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111809µs857µsPod::Perldoc::::BEGIN@30 Pod::Perldoc::BEGIN@30
11119µs19µsPONAPI::CLI::Command::manual::::BEGIN@1PONAPI::CLI::Command::manual::BEGIN@1
11119µs19µsPod::Perldoc::::CORE:fteexec Pod::Perldoc::CORE:fteexec (opcode)
11111µs21µsPod::Perldoc::::BEGIN@94 Pod::Perldoc::BEGIN@94
11110µs11µsPod::Perldoc::::BEGIN@64 Pod::Perldoc::BEGIN@64
1119µs9µsPod::Perldoc::::BEGIN@19 Pod::Perldoc::BEGIN@19
1118µs203µsPod::Perldoc::::BEGIN@8 Pod::Perldoc::BEGIN@8
1118µs42µsPod::Perldoc::::BEGIN@9 Pod::Perldoc::BEGIN@9
1118µs33µsPod::Perldoc::::BEGIN@10 Pod::Perldoc::BEGIN@10
1117µs12µsPod::Perldoc::::BEGIN@5 Pod::Perldoc::BEGIN@5
1117µs35µsPod::Perldoc::::BEGIN@31 Pod::Perldoc::BEGIN@31
1116µs17µsPod::Perldoc::::BEGIN@6 Pod::Perldoc::BEGIN@6
1116µs67µsPod::Perldoc::::BEGIN@12 Pod::Perldoc::BEGIN@12
1116µs17µsPod::Perldoc::::BEGIN@4 Pod::Perldoc::BEGIN@4
1115µs13µsPod::Perldoc::::BEGIN@95 Pod::Perldoc::BEGIN@95
2211µs1µsPod::Perldoc::::CORE:match Pod::Perldoc::CORE:match (opcode)
0000s0sPod::Perldoc::::FALSE Pod::Perldoc::FALSE
0000s0sPod::Perldoc::::__ANON__[:95] Pod::Perldoc::__ANON__[:95]
0000s0sPod::Perldoc::::_elem Pod::Perldoc::_elem
0000s0sPod::Perldoc::::add_formatter_option Pod::Perldoc::add_formatter_option
0000s0sPod::Perldoc::::add_translator Pod::Perldoc::add_translator
0000s0sPod::Perldoc::::after_rendering Pod::Perldoc::after_rendering
0000s0sPod::Perldoc::::after_rendering_Dos Pod::Perldoc::after_rendering_Dos
0000s0sPod::Perldoc::::after_rendering_MSWin32 Pod::Perldoc::after_rendering_MSWin32
0000s0sPod::Perldoc::::after_rendering_OS2 Pod::Perldoc::after_rendering_OS2
0000s0sPod::Perldoc::::after_rendering_VMS Pod::Perldoc::after_rendering_VMS
0000s0sPod::Perldoc::::am_taint_checking Pod::Perldoc::am_taint_checking
0000s0sPod::Perldoc::::aside Pod::Perldoc::aside
0000s0sPod::Perldoc::::assert_closing_stdout Pod::Perldoc::assert_closing_stdout
0000s0sPod::Perldoc::::check_file Pod::Perldoc::check_file
0000s0sPod::Perldoc::::containspod Pod::Perldoc::containspod
0000s0sPod::Perldoc::::debug Pod::Perldoc::debug
0000s0sPod::Perldoc::::debugging Pod::Perldoc::debugging
0000s0sPod::Perldoc::::die Pod::Perldoc::die
0000s0sPod::Perldoc::::drop_privs_maybe Pod::Perldoc::drop_privs_maybe
0000s0sPod::Perldoc::::find_good_formatter_class Pod::Perldoc::find_good_formatter_class
0000s0sPod::Perldoc::::formatter_sanity_check Pod::Perldoc::formatter_sanity_check
0000s0sPod::Perldoc::::grand_search_init Pod::Perldoc::grand_search_init
0000s0sPod::Perldoc::::init Pod::Perldoc::init
0000s0sPod::Perldoc::::init_formatter_class_list Pod::Perldoc::init_formatter_class_list
0000s0sPod::Perldoc::::is_tainted Pod::Perldoc::is_tainted
0000s0sPod::Perldoc::::isprintable Pod::Perldoc::isprintable
0000s0sPod::Perldoc::::maybe_diddle_INC Pod::Perldoc::maybe_diddle_INC
0000s0sPod::Perldoc::::maybe_generate_dynamic_pod Pod::Perldoc::maybe_generate_dynamic_pod
0000s0sPod::Perldoc::::minus_f_nocase Pod::Perldoc::minus_f_nocase
0000s0sPod::Perldoc::::new Pod::Perldoc::new
0000s0sPod::Perldoc::::new_output_file Pod::Perldoc::new_output_file
0000s0sPod::Perldoc::::new_tempfile Pod::Perldoc::new_tempfile
0000s0sPod::Perldoc::::new_translator Pod::Perldoc::new_translator
0000s0sPod::Perldoc::::not_dynamic Pod::Perldoc::not_dynamic
0000s0sPod::Perldoc::::opt_L_with Pod::Perldoc::opt_L_with
0000s0sPod::Perldoc::::opt_M_with Pod::Perldoc::opt_M_with
0000s0sPod::Perldoc::::opt_V Pod::Perldoc::opt_V
0000s0sPod::Perldoc::::opt_d_with Pod::Perldoc::opt_d_with
0000s0sPod::Perldoc::::opt_f_with Pod::Perldoc::opt_f_with
0000s0sPod::Perldoc::::opt_n_with Pod::Perldoc::opt_n_with
0000s0sPod::Perldoc::::opt_o_with Pod::Perldoc::opt_o_with
0000s0sPod::Perldoc::::opt_q_with Pod::Perldoc::opt_q_with
0000s0sPod::Perldoc::::opt_t Pod::Perldoc::opt_t
0000s0sPod::Perldoc::::opt_u Pod::Perldoc::opt_u
0000s0sPod::Perldoc::::opt_v_with Pod::Perldoc::opt_v_with
0000s0sPod::Perldoc::::opt_w_with Pod::Perldoc::opt_w_with
0000s0sPod::Perldoc::::options_processing Pod::Perldoc::options_processing
0000s0sPod::Perldoc::::options_reading Pod::Perldoc::options_reading
0000s0sPod::Perldoc::::options_sanity Pod::Perldoc::options_sanity
0000s0sPod::Perldoc::::page Pod::Perldoc::page
0000s0sPod::Perldoc::::page_module_file Pod::Perldoc::page_module_file
0000s0sPod::Perldoc::::pagers Pod::Perldoc::pagers
0000s0sPod::Perldoc::::pagers_guessing Pod::Perldoc::pagers_guessing
0000s0sPod::Perldoc::::process Pod::Perldoc::process
0000s0sPod::Perldoc::::program_name Pod::Perldoc::program_name
0000s0sPod::Perldoc::::render_and_page Pod::Perldoc::render_and_page
0000s0sPod::Perldoc::::render_findings Pod::Perldoc::render_findings
0000s0sPod::Perldoc::::run Pod::Perldoc::run
0000s0sPod::Perldoc::::search_perlfaqs Pod::Perldoc::search_perlfaqs
0000s0sPod::Perldoc::::search_perlfunc Pod::Perldoc::search_perlfunc
0000s0sPod::Perldoc::::search_perlop Pod::Perldoc::search_perlop
0000s0sPod::Perldoc::::search_perlvar Pod::Perldoc::search_perlvar
0000s0sPod::Perldoc::::searchfor Pod::Perldoc::searchfor
0000s0sPod::Perldoc::::tweak_found_pathnames Pod::Perldoc::tweak_found_pathnames
0000s0sPod::Perldoc::::unlink_if_temp_file Pod::Perldoc::unlink_if_temp_file
0000s0sPod::Perldoc::::usage Pod::Perldoc::usage
0000s0sPod::Perldoc::::usage_brief Pod::Perldoc::usage_brief
0000s0sPod::Perldoc::::useful_filename_bit Pod::Perldoc::useful_filename_bit
0000s0sPod::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
1250µs119µ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
3package Pod::Perldoc;
4219µs228µ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
5222µs217µ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
6222µs228µ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
8224µs2398µ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
9224µs276µ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
10228µs258µ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
1214µs161µ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
14190µs167µs);
# spent 67µs making 1 call to Pod::Perldoc::BEGIN@12
151600ns$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...
2014µs unless(defined &DEBUG) {
2115µs1300ns 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 {
251800ns *DEBUG = sub () {0};
26 }
27 }
28118µs19µs}
# spent 9µs making 1 call to Pod::Perldoc::BEGIN@19
29
302421µs1857µ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
312269µs263µ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
34sub debugging {
35 my $self = shift;
36
37 ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() )
38 }
39
40sub debug {
41 my( $self, @messages ) = @_;
42 return unless $self->debugging;
43 print STDERR map { "DEBUG : $_" } @messages;
44 }
45
46sub warn {
47 my( $self, @messages ) = @_;
48
49 carp( join "\n", @messages, '' );
50 }
51
52sub die {
53 my( $self, @messages ) = @_;
54
55 croak( join "\n", @messages, '' );
56 }
57
58#..........................................................................
59
60sub TRUE () {1}
61sub FALSE () {return}
62sub 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 {
6512µs *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms;
661500ns *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
671400ns *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos;
681300ns *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2;
691300ns *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin;
701400ns *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux;
7117µs1800ns *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux;
# spent 800ns making 1 call to Pod::Perldoc::CORE:match
72196µs111µs}
# spent 11µs making 1 call to Pod::Perldoc::BEGIN@64
73
741300ns$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#..........................................................................
81210µs11.89ms{ my $pager = $Config{'pager'};
# spent 1.89ms making 1 call to Config::FETCH
82127µs119µ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}
8415µs133µs$Bindir = $Config{'scriptdirexp'};
# spent 33µs making 1 call to Config::FETCH
8514µs131µ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
9317µsforeach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) {
94224µs232µ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
95347.35ms221µ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:
99sub opt_f_with { shift->_elem('opt_f', @_) }
100sub opt_q_with { shift->_elem('opt_q', @_) }
101sub opt_d_with { shift->_elem('opt_d', @_) }
102sub opt_L_with { shift->_elem('opt_L', @_) }
103sub opt_v_with { shift->_elem('opt_v', @_) }
104
105sub 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
118sub 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
143sub 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
157sub 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
163sub 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
169sub 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
176sub 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
212sub 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
231sub 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
241sub 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
261sub 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 );
269perldoc [options] PageName|ModuleName|ProgramName|URL...
270perldoc [options] -f BuiltinFunction
271perldoc [options] -q FAQRegex
272perldoc [options] -v PerlVariable
273
274Options:
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
298PageName|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
305BuiltinFunction
306 is the name of a perl function. Will extract documentation from
307 `perlfunc' or `perlop'.
308
309FAQRegex
310 is a regex. Will search perlfaq[1-9] for and extract any
311 questions that match.
312
313Any switches in the PERLDOC environment variable will be used before the
314command line arguments. The optional pod index file contains a list of
315filenames, one per line.
316 [Perldoc v$VERSION]
317EOF
318
319}
320
321#..........................................................................
322
323sub 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");
356You called the perldoc command with a name that I didn't recognize.
357This might mean that someone is tricking you into running a
358program you don't intend to use, but it also might mean that you
359created your own link to perldoc. I think your program name is
360[$basename].
361
362I'll allow this if the filename only has [a-zA-Z0-9._-].
363HERE
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");
375I think that your name for perldoc is potentially unsafe, so I'm
376going to disallow it. I'd rather you be safe than sorry. If you
377intended to use the name I'm disallowing, please tell the maintainers
378about it. Write to:
379
380 Pod-Perldoc\@rt.cpan.org
381
382HERE
383}
384
385#..........................................................................
386
387sub usage_brief {
388 my $self = shift;
389 my $program_name = $self->program_name;
390
391 CORE::die( <<"EOUSAGE" );
392Usage: $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
397Examples:
398
399 $program_name -f PerlFunc
400 $program_name -q FAQKeywords
401 $program_name -v PerlVar
402
403The -h option prints more help. Also try "$program_name perldoc" to get
404acquainted with the system. [Perldoc v$VERSION]
405EOUSAGE
406
407}
408
409#..........................................................................
410
411sub pagers { @{ shift->{'pagers'} } }
412
413#..........................................................................
414
415sub _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
426sub 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
464sub 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
483sub 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
5552800nsmy( %class_seen, %class_loaded );
556sub 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
633sub 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
660sub 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
712sub 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
743sub 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
780sub 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
812sub 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
915sub 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
958sub not_dynamic {
959 my ($self,$value) = @_;
960 $self->{__not_dynamic} = $value if @_ == 2;
961 return $self->{__not_dynamic};
962}
963
964#..........................................................................
965
966sub 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
978sub 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
996sub 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
1016sub 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
1090sub 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
1143sub 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
1230sub 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 );
1239Invalid regular expression '$search_key' given as -q pattern:
1240$@
1241Did you mean \\Q$search_key ?
1242
1243EOD
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
1275sub 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
1378sub 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
1400sub 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
1409sub after_rendering_VMS { return }
1410sub after_rendering_Dos { return }
1411sub after_rendering_OS2 { return }
1412sub after_rendering_MSWin32 { return }
1413
1414#..........................................................................
1415# : : : : : : : : :
1416#..........................................................................
1417
1418sub 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
1484sub 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
1524sub 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
1553sub 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
1584sub 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
1603sub 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
1641sub 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
1663sub 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
1689sub 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
1719sub 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
1730sub 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
1766sub 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{
18182400ns 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
1835sub 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
1848sub 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
1857sub 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
1867sub 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
191819µs1;
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