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