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