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