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