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