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