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