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