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