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