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