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