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