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