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