source: for-distributions/trunk/bin/windows/perl/lib/Pod/Perldoc.pm@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago

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