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