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