1 2require 5; 3use 5.006; # we use some open(X, "<", $y) syntax 4package Pod::Perldoc; 5use strict; 6use warnings; 7use Config '%Config'; 8 9use Fcntl; # for sysopen 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.12'; 16#.......................................................................... 17 18BEGIN { # Make a DEBUG constant very first thing... 19 unless(defined &DEBUG) { 20 if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint 21 eval("sub DEBUG () {$1}"); 22 die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; 23 } else { 24 *DEBUG = sub () {0}; 25 } 26 } 27} 28 29use Pod::Perldoc::GetOptsOO; # uses the DEBUG. 30 31#.......................................................................... 32 33sub TRUE () {1} 34sub FALSE () {return} 35 36BEGIN { 37 *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; 38 *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; 39 *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; 40 *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; 41 *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; 42 *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; 43 *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; 44} 45 46$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; 47 # If it's older than five days, it's quite unlikely 48 # that anyone's still looking at it!! 49 # (Currently used only by the MSWin cleanup routine) 50 51 52#.......................................................................... 53{ my $pager = $Config{'pager'}; 54 push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; 55} 56$Bindir = $Config{'scriptdirexp'}; 57$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); 58 59# End of class-init stuff 60# 61########################################################################### 62# 63# Option accessors... 64 65foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) { 66 no strict 'refs'; 67 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; 68} 69 70# And these are so that GetOptsOO knows they take options: 71sub opt_f_with { shift->_elem('opt_f', @_) } 72sub opt_q_with { shift->_elem('opt_q', @_) } 73sub opt_d_with { shift->_elem('opt_d', @_) } 74 75sub opt_w_with { # Specify an option for the formatter subclass 76 my($self, $value) = @_; 77 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { 78 my $option = $1; 79 my $option_value = defined($2) ? $2 : "TRUE"; 80 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" 81 $self->add_formatter_option( $option, $option_value ); 82 } else { 83 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; 84 } 85 return; 86} 87 88sub opt_M_with { # specify formatter class name(s) 89 my($self, $classes) = @_; 90 return unless defined $classes and length $classes; 91 DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; 92 my @classes_to_add; 93 foreach my $classname (split m/[,;]+/s, $classes) { 94 next unless $classname =~ m/\S/; 95 if( $classname =~ m/^(\w+(::\w+)+)$/s ) { 96 # A mildly restrictive concept of what modulenames are valid. 97 push @classes_to_add, $1; # untaint 98 } else { 99 warn "\"$classname\" isn't a valid classname. Ignoring.\n"; 100 } 101 } 102 103 unshift @{ $self->{'formatter_classes'} }, @classes_to_add; 104 105 DEBUG > 3 and print( 106 "Adding @classes_to_add to the list of formatter classes, " 107 . "making them @{ $self->{'formatter_classes'} }.\n" 108 ); 109 110 return; 111} 112 113sub opt_V { # report version and exit 114 print join '', 115 "Perldoc v$VERSION, under perl v$] for $^O", 116 117 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) 118 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), 119 120 (chr(65) eq 'A') ? () : " (non-ASCII)", 121 122 "\n", 123 ; 124 exit; 125} 126 127sub opt_t { # choose plaintext as output format 128 my $self = shift; 129 $self->opt_o_with('text') if @_ and $_[0]; 130 return $self->_elem('opt_t', @_); 131} 132 133sub opt_u { # choose raw pod as output format 134 my $self = shift; 135 $self->opt_o_with('pod') if @_ and $_[0]; 136 return $self->_elem('opt_u', @_); 137} 138 139sub opt_n_with { 140 # choose man as the output format, and specify the proggy to run 141 my $self = shift; 142 $self->opt_o_with('man') if @_ and $_[0]; 143 $self->_elem('opt_n', @_); 144} 145 146sub opt_o_with { # "o" for output format 147 my($self, $rest) = @_; 148 return unless defined $rest and length $rest; 149 if($rest =~ m/^(\w+)$/s) { 150 $rest = $1; #untaint 151 } else { 152 warn "\"$rest\" isn't a valid output format. Skipping.\n"; 153 return; 154 } 155 156 $self->aside("Noting \"$rest\" as desired output format...\n"); 157 158 # Figure out what class(es) that could actually mean... 159 160 my @classes; 161 foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { 162 # Messy but smart: 163 foreach my $stem ( 164 $rest, # Yes, try it first with the given capitalization 165 "\L$rest", "\L\u$rest", "\U$rest" # And then try variations 166 167 ) { 168 push @classes, $prefix . $stem; 169 #print "Considering $prefix$stem\n"; 170 } 171 172 # Tidier, but misses too much: 173 #push @classes, $prefix . ucfirst(lc($rest)); 174 } 175 $self->opt_M_with( join ";", @classes ); 176 return; 177} 178 179########################################################################### 180# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % 181 182sub run { # to be called by the "perldoc" executable 183 my $class = shift; 184 if(DEBUG > 3) { 185 print "Parameters to $class\->run:\n"; 186 my @x = @_; 187 while(@x) { 188 $x[1] = '<undef>' unless defined $x[1]; 189 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; 190 print " [$x[0]] => [$x[1]]\n"; 191 splice @x,0,2; 192 } 193 print "\n"; 194 } 195 return $class -> new(@_) -> process() || 0; 196} 197 198# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % 199########################################################################### 200 201sub new { # yeah, nothing fancy 202 my $class = shift; 203 my $new = bless {@_}, (ref($class) || $class); 204 DEBUG > 1 and print "New $class object $new\n"; 205 $new->init(); 206 $new; 207} 208 209#.......................................................................... 210 211sub aside { # If we're in -v or DEBUG mode, say this. 212 my $self = shift; 213 if( DEBUG or $self->opt_v ) { 214 my $out = join( '', 215 DEBUG ? do { 216 my $callsub = (caller(1))[3]; 217 my $package = quotemeta(__PACKAGE__ . '::'); 218 $callsub =~ s/^$package/'/os; 219 # the o is justified, as $package really won't change. 220 $callsub . ": "; 221 } : '', 222 @_, 223 ); 224 if(DEBUG) { print $out } else { print STDERR $out } 225 } 226 return; 227} 228 229#.......................................................................... 230 231sub usage { 232 my $self = shift; 233 warn "@_\n" if @_; 234 235 # Erase evidence of previous errors (if any), so exit status is simple. 236 $! = 0; 237 238 die <<EOF; 239perldoc [options] PageName|ModuleName|ProgramName... 240perldoc [options] -f BuiltinFunction 241perldoc [options] -q FAQRegex 242 243Options: 244 -h Display this help message 245 -V report version 246 -r Recursive search (slow) 247 -i Ignore case 248 -t Display pod using pod2text instead of pod2man and nroff 249 (-t is the default on win32 unless -n is specified) 250 -u Display unformatted pod text 251 -m Display module's file in its entirety 252 -n Specify replacement for nroff 253 -l Display the module's file name 254 -F Arguments are file names, not modules 255 -v Verbosely describe what's going on 256 -T Send output to STDOUT without any pager 257 -d output_filename_to_send_to 258 -o output_format_name 259 -M FormatterModuleNameToUse 260 -w formatter_option:option_value 261 -X use index if present (looks for pod.idx at $Config{archlib}) 262 -q Search the text of questions (not answers) in perlfaq[1-9] 263 264PageName|ModuleName... 265 is the name of a piece of documentation that you want to look at. You 266 may either give a descriptive name of the page (as in the case of 267 `perlfunc') the name of a module, either like `Term::Info' or like 268 `Term/Info', or the name of a program, like `perldoc'. 269 270BuiltinFunction 271 is the name of a perl function. Will extract documentation from 272 `perlfunc'. 273 274FAQRegex 275 is a regex. Will search perlfaq[1-9] for and extract any 276 questions that match. 277 278Any switches in the PERLDOC environment variable will be used before the 279command line arguments. The optional pod index file contains a list of 280filenames, one per line. 281 [Perldoc v$VERSION] 282EOF 283 284} 285 286#.......................................................................... 287 288sub usage_brief { 289 my $me = $0; # Editing $0 is unportable 290 291 $me =~ s,.*[/\\],,; # get basename 292 293 die <<"EOUSAGE"; 294Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName 295 $me -f PerlFunc 296 $me -q FAQKeywords 297 298The -h option prints more help. Also try "perldoc perldoc" to get 299acquainted with the system. [Perldoc v$VERSION] 300EOUSAGE 301 302} 303 304#.......................................................................... 305 306sub pagers { @{ shift->{'pagers'} } } 307 308#.......................................................................... 309 310sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) 311 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } 312 else { return $_[0]{ $_[1] } } 313} 314#.......................................................................... 315########################################################################### 316# 317# Init formatter switches, and start it off with __bindir and all that 318# other stuff that ToMan.pm needs. 319# 320 321sub init { 322 my $self = shift; 323 324 # Make sure creat()s are neither too much nor too little 325 eval { umask(0077) }; # doubtless someone has no mask 326 327 $self->{'args'} ||= \@ARGV; 328 $self->{'found'} ||= []; 329 $self->{'temp_file_list'} ||= []; 330 331 332 $self->{'target'} = undef; 333 334 $self->init_formatter_class_list; 335 336 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; 337 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; 338 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; 339 340 push @{ $self->{'formatter_switches'} = [] }, ( 341 # Yeah, we could use a hashref, but maybe there's some class where options 342 # have to be ordered; so we'll use an arrayref. 343 344 [ '__bindir' => $self->{'bindir' } ], 345 [ '__pod2man' => $self->{'pod2man'} ], 346 ); 347 348 DEBUG > 3 and printf "Formatter switches now: [%s]\n", 349 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 350 351 return; 352} 353 354#.......................................................................... 355 356sub init_formatter_class_list { 357 my $self = shift; 358 $self->{'formatter_classes'} ||= []; 359 360 # Remember, no switches have been read yet, when 361 # we've started this routine. 362 363 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru 364 $self->opt_o_with('text'); 365 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos 366 || !($ENV{TERM} && ( 367 ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i 368 )); 369 370 return; 371} 372 373#.......................................................................... 374 375sub process { 376 # if this ever returns, its retval will be used for exit(RETVAL) 377 378 my $self = shift; 379 DEBUG > 1 and print " Beginning process.\n"; 380 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; 381 if(DEBUG > 3) { 382 print "Object contents:\n"; 383 my @x = %$self; 384 while(@x) { 385 $x[1] = '<undef>' unless defined $x[1]; 386 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; 387 print " [$x[0]] => [$x[1]]\n"; 388 splice @x,0,2; 389 } 390 print "\n"; 391 } 392 393 # TODO: make it deal with being invoked as various different things 394 # such as perlfaq". 395 396 return $self->usage_brief unless @{ $self->{'args'} }; 397 $self->pagers_guessing; 398 $self->options_reading; 399 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); 400 $self->drop_privs_maybe; 401 $self->options_processing; 402 403 # Hm, we have @pages and @found, but we only really act on one 404 # file per call, with the exception of the opt_q hack, and with 405 # -l things 406 407 $self->aside("\n"); 408 409 my @pages; 410 $self->{'pages'} = \@pages; 411 if( $self->opt_f) { @pages = ("perlfunc") } 412 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } 413 else { @pages = @{$self->{'args'}}; 414 # @pages = __FILE__ 415 # if @pages == 1 and $pages[0] eq 'perldoc'; 416 } 417 418 return $self->usage_brief unless @pages; 419 420 $self->find_good_formatter_class(); 421 $self->formatter_sanity_check(); 422 423 $self->maybe_diddle_INC(); 424 # for when we're apparently in a module or extension directory 425 426 my @found = $self->grand_search_init(\@pages); 427 exit (IS_VMS ? 98962 : 1) unless @found; 428 429 if ($self->opt_l) { 430 DEBUG and print "We're in -l mode, so byebye after this:\n"; 431 print join("\n", @found), "\n"; 432 return; 433 } 434 435 $self->tweak_found_pathnames(\@found); 436 $self->assert_closing_stdout; 437 return $self->page_module_file(@found) if $self->opt_m; 438 DEBUG > 2 and print "Found: [@found]\n"; 439 440 return $self->render_and_page(\@found); 441} 442 443#.......................................................................... 444{ 445 446my( %class_seen, %class_loaded ); 447sub find_good_formatter_class { 448 my $self = $_[0]; 449 my @class_list = @{ $self->{'formatter_classes'} || [] }; 450 die "WHAT? Nothing in the formatter class list!?" unless @class_list; 451 452 my $good_class_found; 453 foreach my $c (@class_list) { 454 DEBUG > 4 and print "Trying to load $c...\n"; 455 if($class_loaded{$c}) { 456 DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; 457 $good_class_found = $c; 458 last; 459 } 460 461 if($class_seen{$c}) { 462 DEBUG > 4 and print 463 "I've tried $c before, and it's no good. Skipping.\n"; 464 next; 465 } 466 467 $class_seen{$c} = 1; 468 469 if( $c->can('parse_from_file') ) { 470 DEBUG > 4 and print 471 "Interesting, the formatter class $c is already loaded!\n"; 472 473 } elsif( 474 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) 475 # the alway case-insensitive fs's 476 and $class_seen{lc("~$c")}++ 477 ) { 478 DEBUG > 4 and print 479 "We already used something quite like \"\L$c\E\", so no point using $c\n"; 480 # This avoids redefining the package. 481 } else { 482 DEBUG > 4 and print "Trying to eval 'require $c'...\n"; 483 484 local $^W = $^W; 485 if(DEBUG() or $self->opt_v) { 486 # feh, let 'em see it 487 } else { 488 $^W = 0; 489 # The average user just has no reason to be seeing 490 # $^W-suppressable warnings from the the require! 491 } 492 493 eval "require $c"; 494 if($@) { 495 DEBUG > 4 and print "Couldn't load $c: $!\n"; 496 next; 497 } 498 } 499 500 if( $c->can('parse_from_file') ) { 501 DEBUG > 4 and print "Settling on $c\n"; 502 my $v = $c->VERSION; 503 $v = ( defined $v and length $v ) ? " version $v" : ''; 504 $self->aside("Formatter class $c$v successfully loaded!\n"); 505 $good_class_found = $c; 506 last; 507 } else { 508 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; 509 } 510 } 511 512 die "Can't find any loadable formatter class in @class_list?!\nAborting" 513 unless $good_class_found; 514 515 $self->{'formatter_class'} = $good_class_found; 516 $self->aside("Will format with the class $good_class_found\n"); 517 518 return; 519} 520 521} 522#.......................................................................... 523 524sub formatter_sanity_check { 525 my $self = shift; 526 my $formatter_class = $self->{'formatter_class'} 527 || die "NO FORMATTER CLASS YET!?"; 528 529 if(!$self->opt_T # so -T can FORCE sending to STDOUT 530 and $formatter_class->can('is_pageable') 531 and !$formatter_class->is_pageable 532 and !$formatter_class->can('page_for_perldoc') 533 ) { 534 my $ext = 535 ($formatter_class->can('output_extension') 536 && $formatter_class->output_extension 537 ) || ''; 538 $ext = ".$ext" if length $ext; 539 540 die 541 "When using Perldoc to format with $formatter_class, you have to\n" 542 . "specify -T or -dsomefile$ext\n" 543 . "See `perldoc perldoc' for more information on those switches.\n" 544 ; 545 } 546} 547 548#.......................................................................... 549 550sub render_and_page { 551 my($self, $found_list) = @_; 552 553 $self->maybe_generate_dynamic_pod($found_list); 554 555 my($out, $formatter) = $self->render_findings($found_list); 556 557 if($self->opt_d) { 558 printf "Perldoc (%s) output saved to %s\n", 559 $self->{'formatter_class'} || ref($self), 560 $out; 561 print "But notice that it's 0 bytes long!\n" unless -s $out; 562 563 564 } elsif( # Allow the formatter to "page" itself, if it wants. 565 $formatter->can('page_for_perldoc') 566 and do { 567 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); 568 if( $formatter->page_for_perldoc($out, $self) ) { 569 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); 570 1; 571 } else { 572 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); 573 ''; 574 } 575 } 576 ) { 577 # Do nothing, since the formatter has "paged" it for itself. 578 579 } else { 580 # Page it normally (internally) 581 582 if( -s $out ) { # Usual case: 583 $self->page($out, $self->{'output_to_stdout'}, $self->pagers); 584 585 } else { 586 # Odd case: 587 $self->aside("Skipping $out (from $$found_list[0] " 588 . "via $$self{'formatter_class'}) as it is 0-length.\n"); 589 590 push @{ $self->{'temp_file_list'} }, $out; 591 $self->unlink_if_temp_file($out); 592 } 593 } 594 595 $self->after_rendering(); # any extra cleanup or whatever 596 597 return; 598} 599 600#.......................................................................... 601 602sub options_reading { 603 my $self = shift; 604 605 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { 606 require Text::ParseWords; 607 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); 608 # Yes, appends to the beginning 609 unshift @{ $self->{'args'} }, 610 Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) 611 ; 612 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; 613 } else { 614 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; 615 } 616 617 DEBUG > 1 618 and print " Args right before switch processing: @{$self->{'args'}}\n"; 619 620 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) 621 or return $self->usage; 622 623 DEBUG > 1 624 and print " Args after switch processing: @{$self->{'args'}}\n"; 625 626 return $self->usage if $self->opt_h; 627 628 return; 629} 630 631#.......................................................................... 632 633sub options_processing { 634 my $self = shift; 635 636 if ($self->opt_X) { 637 my $podidx = "$Config{'archlib'}/pod.idx"; 638 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; 639 $self->{'podidx'} = $podidx; 640 } 641 642 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; 643 644 $self->options_sanity; 645 646 $self->opt_n("nroff") unless $self->opt_n; 647 $self->add_formatter_option( '__nroffer' => $self->opt_n ); 648 649 return; 650} 651 652#.......................................................................... 653 654sub options_sanity { 655 my $self = shift; 656 657 # The opts-counting stuff interacts quite badly with 658 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} 659 # set to -t, and I specify -u on the command line, I don't want 660 # to be hectored at that -u and -t don't make sense together. 661 662 #my $opts = grep $_ && 1, # yes, the count of the set ones 663 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l 664 #; 665 # 666 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; 667 668 669 # Any sanity-checking need doing here? 670 671 return; 672} 673 674#.......................................................................... 675 676sub grand_search_init { 677 my($self, $pages, @found) = @_; 678 679 foreach (@$pages) { 680 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { 681 my $searchfor = catfile split '::', $_; 682 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); 683 local $_; 684 while (<PODIDX>) { 685 chomp; 686 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; 687 } 688 close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; 689 next; 690 } 691 692 $self->aside( "Searching for $_\n" ); 693 694 if ($self->opt_F) { 695 next unless -r; 696 push @found, $_ if $self->opt_m or $self->containspod($_); 697 next; 698 } 699 700 # We must look both in @INC for library modules and in $bindir 701 # for executables, like h2xs or perldoc itself. 702 703 my @searchdirs = ($self->{'bindir'}, @INC); 704 unless ($self->opt_m) { 705 if (IS_VMS) { 706 my($i,$trn); 707 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { 708 push(@searchdirs,$trn); 709 } 710 push(@searchdirs,'perl_root:[lib.pod]') # installed pods 711 } 712 else { 713 push(@searchdirs, grep(-d, split($Config{path_sep}, 714 $ENV{'PATH'}))); 715 } 716 } 717 my @files = $self->searchfor(0,$_,@searchdirs); 718 if (@files) { 719 $self->aside( "Found as @files\n" ); 720 } 721 else { 722 # no match, try recursive search 723 @searchdirs = grep(!/^\.\z/s,@INC); 724 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; 725 if (@files) { 726 $self->aside( "Loosely found as @files\n" ); 727 } 728 else { 729 print STDERR "No " . 730 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; 731 if ( @{ $self->{'found'} } ) { 732 print STDERR "However, try\n"; 733 for my $dir (@{ $self->{'found'} }) { 734 opendir(DIR, $dir) or die "opendir $dir: $!"; 735 while (my $file = readdir(DIR)) { 736 next if ($file =~ /^\./s); 737 $file =~ s/\.(pm|pod)\z//; # XXX: badfs 738 print STDERR "\tperldoc $_\::$file\n"; 739 } 740 closedir(DIR) or die "closedir $dir: $!"; 741 } 742 } 743 } 744 } 745 push(@found,@files); 746 } 747 return @found; 748} 749 750#.......................................................................... 751 752sub maybe_generate_dynamic_pod { 753 my($self, $found_things) = @_; 754 my @dynamic_pod; 755 756 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; 757 758 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; 759 760 if( ! $self->opt_f and ! $self->opt_q ) { 761 DEBUG > 4 and print "That's a non-dynamic pod search.\n"; 762 } elsif ( @dynamic_pod ) { 763 $self->aside("Hm, I found some Pod from that search!\n"); 764 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); 765 766 push @{ $self->{'temp_file_list'} }, $buffer; 767 # I.e., it MIGHT be deleted at the end. 768 769 my $in_list = $self->opt_f; 770 771 print $buffd "=over 8\n\n" if $in_list; 772 print $buffd @dynamic_pod or die "Can't print $buffer: $!"; 773 print $buffd "=back\n" if $in_list; 774 775 close $buffd or die "Can't close $buffer: $!"; 776 777 @$found_things = $buffer; 778 # Yes, so found_things never has more than one thing in 779 # it, by time we leave here 780 781 $self->add_formatter_option('__filter_nroff' => 1); 782 783 } else { 784 @$found_things = (); 785 $self->aside("I found no Pod from that search!\n"); 786 } 787 788 return; 789} 790 791#.......................................................................... 792 793sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); 794 my $self = shift; 795 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; 796 797 DEBUG > 3 and printf "Formatter switches now: [%s]\n", 798 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 799 800 return; 801} 802 803#.......................................................................... 804 805sub search_perlfunc { 806 my($self, $found_things, $pod) = @_; 807 808 DEBUG > 2 and print "Search: @$found_things\n"; 809 810 my $perlfunc = shift @$found_things; 811 open(PFUNC, "<", $perlfunc) # "Funk is its own reward" 812 or die("Can't open $perlfunc: $!"); 813 814 # Functions like -r, -e, etc. are listed under `-X'. 815 my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) 816 ? '(?:I<)?-X' : quotemeta($self->opt_f) ; 817 818 DEBUG > 2 and 819 print "Going to perlfunc-scan for $search_re in $perlfunc\n"; 820 821 # Skip introduction 822 local $_; 823 while (<PFUNC>) { 824 last if /^=head2 Alphabetical Listing of Perl Functions/; 825 } 826 827 # Look for our function 828 my $found = 0; 829 my $inlist = 0; 830 while (<PFUNC>) { # "The Mothership Connection is here!" 831 if ( m/^=item\s+$search_re\b/ ) { 832 $found = 1; 833 } 834 elsif (/^=item/) { 835 last if $found > 1 and not $inlist; 836 } 837 next unless $found; 838 if (/^=over/) { 839 ++$inlist; 840 } 841 elsif (/^=back/) { 842 --$inlist; 843 } 844 push @$pod, $_; 845 ++$found if /^\w/; # found descriptive text 846 } 847 if (!@$pod) { 848 die sprintf 849 "No documentation for perl function `%s' found\n", 850 $self->opt_f 851 ; 852 } 853 close PFUNC or die "Can't open $perlfunc: $!"; 854 855 return; 856} 857 858#.......................................................................... 859 860sub search_perlfaqs { 861 my( $self, $found_things, $pod) = @_; 862 863 my $found = 0; 864 my %found_in; 865 my $search_key = $self->opt_q; 866 867 my $rx = eval { qr/$search_key/ } 868 or die <<EOD; 869Invalid regular expression '$search_key' given as -q pattern: 870$@ 871Did you mean \\Q$search_key ? 872 873EOD 874 875 local $_; 876 foreach my $file (@$found_things) { 877 die "invalid file spec: $!" if $file =~ /[<>|]/; 878 open(INFAQ, "<", $file) # XXX 5.6ism 879 or die "Can't read-open $file: $!\nAborting"; 880 while (<INFAQ>) { 881 if ( m/^=head2\s+.*(?:$search_key)/i ) { 882 $found = 1; 883 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; 884 } 885 elsif (/^=head[12]/) { 886 $found = 0; 887 } 888 next unless $found; 889 push @$pod, $_; 890 } 891 close(INFAQ); 892 } 893 die("No documentation for perl FAQ keyword `$search_key' found\n") 894 unless @$pod; 895 896 return; 897} 898 899 900#.......................................................................... 901 902sub render_findings { 903 # Return the filename to open 904 905 my($self, $found_things) = @_; 906 907 my $formatter_class = $self->{'formatter_class'} 908 || die "No formatter class set!?"; 909 my $formatter = $formatter_class->can('new') 910 ? $formatter_class->new 911 : $formatter_class 912 ; 913 914 if(! @$found_things) { 915 die "Nothing found?!"; 916 # should have been caught before here 917 } elsif(@$found_things > 1) { 918 warn join '', 919 "Perldoc is only really meant for reading one document at a time.\n", 920 "So these parameters are being ignored: ", 921 join(' ', @$found_things[1 .. $#$found_things] ), 922 "\n" 923 } 924 925 my $file = $found_things->[0]; 926 927 DEBUG > 3 and printf "Formatter switches now: [%s]\n", 928 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 929 930 # Set formatter options: 931 if( ref $formatter ) { 932 foreach my $f (@{ $self->{'formatter_switches'} || [] }) { 933 my($switch, $value, $silent_fail) = @$f; 934 if( $formatter->can($switch) ) { 935 eval { $formatter->$switch( defined($value) ? $value : () ) }; 936 warn "Got an error when setting $formatter_class\->$switch:\n$@\n" 937 if $@; 938 } else { 939 if( $silent_fail or $switch =~ m/^__/s ) { 940 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; 941 } else { 942 warn "$formatter_class doesn't recognize the $switch switch.\n"; 943 } 944 } 945 } 946 } 947 948 $self->{'output_is_binary'} = 949 $formatter->can('write_with_binmode') && $formatter->write_with_binmode; 950 951 my ($out_fh, $out) = $self->new_output_file( 952 ( $formatter->can('output_extension') && $formatter->output_extension ) 953 || undef, 954 $self->useful_filename_bit, 955 ); 956 957 # Now, finally, do the formatting! 958 { 959 local $^W = $^W; 960 if(DEBUG() or $self->opt_v) { 961 # feh, let 'em see it 962 } else { 963 $^W = 0; 964 # The average user just has no reason to be seeing 965 # $^W-suppressable warnings from the formatting! 966 } 967 968 eval { $formatter->parse_from_file( $file, $out_fh ) }; 969 } 970 971 warn "Error while formatting with $formatter_class:\n $@\n" if $@; 972 DEBUG > 2 and print "Back from formatting with $formatter_class\n"; 973 974 close $out_fh 975 or warn "Can't close $out: $!\n(Did $formatter already close it?)"; 976 sleep 0; sleep 0; sleep 0; 977 # Give the system a few timeslices to meditate on the fact 978 # that the output file does in fact exist and is closed. 979 980 $self->unlink_if_temp_file($file); 981 982 unless( -s $out ) { 983 if( $formatter->can( 'if_zero_length' ) ) { 984 # Basically this is just a hook for Pod::Simple::Checker; since 985 # what other class could /happily/ format an input file with Pod 986 # as a 0-length output file? 987 $formatter->if_zero_length( $file, $out, $out_fh ); 988 } else { 989 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" 990 } 991 } 992 993 DEBUG and print "Finished writing to $out.\n"; 994 return($out, $formatter) if wantarray; 995 return $out; 996} 997 998#.......................................................................... 999 1000sub unlink_if_temp_file { 1001 # Unlink the specified file IFF it's in the list of temp files. 1002 # Really only used in the case of -f / -q things when we can 1003 # throw away the dynamically generated source pod file once 1004 # we've formatted it. 1005 # 1006 my($self, $file) = @_; 1007 return unless defined $file and length $file; 1008 1009 my $temp_file_list = $self->{'temp_file_list'} || return; 1010 if(grep $_ eq $file, @$temp_file_list) { 1011 $self->aside("Unlinking $file\n"); 1012 unlink($file) or warn "Odd, couldn't unlink $file: $!"; 1013 } else { 1014 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; 1015 } 1016 return; 1017} 1018 1019#.......................................................................... 1020 1021sub MSWin_temp_cleanup { 1022 1023 # Nothing particularly MSWin-specific in here, but I don't know if any 1024 # other OS needs its temp dir policed like MSWin does! 1025 1026 my $self = shift; 1027 1028 my $tempdir = $ENV{'TEMP'}; 1029 return unless defined $tempdir and length $tempdir 1030 and -e $tempdir and -d _ and -w _; 1031 1032 $self->aside( 1033 "Considering whether any old files of mine in $tempdir need unlinking.\n" 1034 ); 1035 1036 opendir(TMPDIR, $tempdir) || return; 1037 my @to_unlink; 1038 1039 my $limit = time() - $Temp_File_Lifetime; 1040 1041 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", 1042 ($limit) x 2; 1043 1044 my $filespec; 1045 1046 while(defined($filespec = readdir(TMPDIR))) { 1047 if( 1048 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s 1049 ) { 1050 if( hex($1) < $limit ) { 1051 push @to_unlink, "$tempdir/$filespec"; 1052 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); 1053 } else { 1054 DEBUG > 5 and 1055 printf " $tempdir/$filespec is too recent (after %x)\n", $limit; 1056 } 1057 } else { 1058 DEBUG > 5 and 1059 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; 1060 } 1061 } 1062 closedir(TMPDIR); 1063 $self->aside(sprintf "Unlinked %s items of mine in %s\n", 1064 scalar(unlink(@to_unlink)), 1065 $tempdir 1066 ); 1067 return; 1068} 1069 1070# . . . . . . . . . . . . . . . . . . . . . . . . . 1071 1072sub MSWin_perldoc_tempfile { 1073 my($self, $suffix, $infix) = @_; 1074 1075 my $tempdir = $ENV{'TEMP'}; 1076 return unless defined $tempdir and length $tempdir 1077 and -e $tempdir and -d _ and -w _; 1078 1079 my $spec; 1080 1081 do { 1082 $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup 1083 # Yes, we embed the create-time in the filename! 1084 $tempdir, 1085 $infix || 'x', 1086 time(), 1087 $$, 1088 defined( &Win32::GetTickCount ) 1089 ? (Win32::GetTickCount() & 0xff) 1090 : int(rand 256) 1091 # Under MSWin, $$ values get reused quickly! So if we ran 1092 # perldoc foo and then perldoc bar before there was time for 1093 # time() to increment time."_$$" would likely be the same 1094 # for each process! So we tack on the tick count's lower 1095 # bits (or, in a pinch, rand) 1096 , 1097 $suffix || 'txt'; 1098 ; 1099 } while( -e $spec ); 1100 1101 my $counter = 0; 1102 1103 while($counter < 50) { 1104 my $fh; 1105 # If we are running before perl5.6.0, we can't autovivify 1106 if ($] < 5.006) { 1107 require Symbol; 1108 $fh = Symbol::gensym(); 1109 } 1110 DEBUG > 3 and print "About to try making temp file $spec\n"; 1111 return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism 1112 $self->aside("Can't create temp file $spec: $!\n"); 1113 } 1114 1115 $self->aside("Giving up on making a temp file!\n"); 1116 die "Can't make a tempfile!?"; 1117} 1118 1119#.......................................................................... 1120 1121 1122sub after_rendering { 1123 my $self = $_[0]; 1124 $self->after_rendering_VMS if IS_VMS; 1125 $self->after_rendering_MSWin32 if IS_MSWin32; 1126 $self->after_rendering_Dos if IS_Dos; 1127 $self->after_rendering_OS2 if IS_OS2; 1128 return; 1129} 1130 1131sub after_rendering_VMS { return } 1132sub after_rendering_Dos { return } 1133sub after_rendering_OS2 { return } 1134 1135sub after_rendering_MSWin32 { 1136 shift->MSWin_temp_cleanup() if $Temp_Files_Created; 1137} 1138 1139#.......................................................................... 1140# : : : : : : : : : 1141#.......................................................................... 1142 1143 1144sub minus_f_nocase { # i.e., do like -f, but without regard to case 1145 1146 my($self, $dir, $file) = @_; 1147 my $path = catfile($dir,$file); 1148 return $path if -f $path and -r _; 1149 1150 if(!$self->opt_i 1151 or IS_VMS or IS_MSWin32 1152 or IS_Dos or IS_OS2 1153 ) { 1154 # On a case-forgiving file system, or if case is important, 1155 # that is it, all we can do. 1156 warn "Ignored $path: unreadable\n" if -f _; 1157 return ''; 1158 } 1159 1160 local *DIR; 1161 my @p = ($dir); 1162 my($p,$cip); 1163 foreach $p (splitdir $file){ 1164 my $try = catfile @p, $p; 1165 $self->aside("Scrutinizing $try...\n"); 1166 stat $try; 1167 if (-d _) { 1168 push @p, $p; 1169 if ( $p eq $self->{'target'} ) { 1170 my $tmp_path = catfile @p; 1171 my $path_f = 0; 1172 for (@{ $self->{'found'} }) { 1173 $path_f = 1 if $_ eq $tmp_path; 1174 } 1175 push (@{ $self->{'found'} }, $tmp_path) unless $path_f; 1176 $self->aside( "Found as $tmp_path but directory\n" ); 1177 } 1178 } 1179 elsif (-f _ && -r _) { 1180 return $try; 1181 } 1182 elsif (-f _) { 1183 warn "Ignored $try: unreadable\n"; 1184 } 1185 elsif (-d catdir(@p)) { # at least we see the containing directory! 1186 my $found = 0; 1187 my $lcp = lc $p; 1188 my $p_dirspec = catdir(@p); 1189 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; 1190 while(defined( $cip = readdir(DIR) )) { 1191 if (lc $cip eq $lcp){ 1192 $found++; 1193 last; # XXX stop at the first? what if there's others? 1194 } 1195 } 1196 closedir DIR or die "closedir $p_dirspec: $!"; 1197 return "" unless $found; 1198 1199 push @p, $cip; 1200 my $p_filespec = catfile(@p); 1201 return $p_filespec if -f $p_filespec and -r _; 1202 warn "Ignored $p_filespec: unreadable\n" if -f _; 1203 } 1204 } 1205 return ""; 1206} 1207 1208#.......................................................................... 1209 1210sub pagers_guessing { 1211 my $self = shift; 1212 1213 my @pagers; 1214 push @pagers, $self->pagers; 1215 $self->{'pagers'} = \@pagers; 1216 1217 if (IS_MSWin32) { 1218 push @pagers, qw( more< less notepad ); 1219 unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1220 } 1221 elsif (IS_VMS) { 1222 push @pagers, qw( most more less type/page ); 1223 } 1224 elsif (IS_Dos) { 1225 push @pagers, qw( less.exe more.com< ); 1226 unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1227 } 1228 else { 1229 if (IS_OS2) { 1230 unshift @pagers, 'less', 'cmd /c more <'; 1231 } 1232 push @pagers, qw( more less pg view cat ); 1233 unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1234 } 1235 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; 1236 1237 return; 1238} 1239 1240#.......................................................................... 1241 1242sub page_module_file { 1243 my($self, @found) = @_; 1244 1245 # Security note: 1246 # Don't ever just pass this off to anything like MSWin's "start.exe", 1247 # since we might be calling on a .pl file, and we wouldn't want that 1248 # to actually /execute/ the file that we just want to page thru! 1249 # Also a consideration if one were to use a web browser as a pager; 1250 # doing so could trigger the browser's MIME mapping for whatever 1251 # it thinks .pm/.pl/whatever is. Probably just a (useless and 1252 # annoying) "Save as..." dialog, but potentially executing the file 1253 # in question -- particularly in the case of MSIE and it's, ahem, 1254 # occasionally hazy distinction between OS-local extension 1255 # associations, and browser-specific MIME mappings. 1256 1257 if ($self->{'output_to_stdout'}) { 1258 $self->aside("Sending unpaged output to STDOUT.\n"); 1259 local $_; 1260 my $any_error = 0; 1261 foreach my $output (@found) { 1262 unless( open(TMP, "<", $output) ) { # XXX 5.6ism 1263 warn("Can't open $output: $!"); 1264 $any_error = 1; 1265 next; 1266 } 1267 while (<TMP>) { 1268 print or die "Can't print to stdout: $!"; 1269 } 1270 close TMP or die "Can't close while $output: $!"; 1271 $self->unlink_if_temp_file($output); 1272 } 1273 return $any_error; # successful 1274 } 1275 1276 foreach my $pager ( $self->pagers ) { 1277 $self->aside("About to try calling $pager @found\n"); 1278 if (system($pager, @found) == 0) { 1279 $self->aside("Yay, it worked.\n"); 1280 return 0; 1281 } 1282 $self->aside("That didn't work.\n"); 1283 1284 # Odd -- when it fails, under Win32, this seems to neither 1285 # return with a fail nor return with a success!! 1286 # That's discouraging! 1287 } 1288 1289 $self->aside( 1290 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", 1291 join(' ', @found), 1292 join(' ', $self->pagers), 1293 ); 1294 1295 if (IS_VMS) { 1296 DEBUG > 1 and print "Bailing out in a VMSish way.\n"; 1297 eval q{ 1298 use vmsish qw(status exit); 1299 exit $?; 1300 1; 1301 } or die; 1302 } 1303 1304 return 1; 1305 # i.e., an UNSUCCESSFUL return value! 1306} 1307 1308#.......................................................................... 1309 1310sub check_file { 1311 my($self, $dir, $file) = @_; 1312 1313 unless( ref $self ) { 1314 # Should never get called: 1315 $Carp::Verbose = 1; 1316 Carp::croak join '', 1317 "Crazy ", __PACKAGE__, " error:\n", 1318 "check_file must be an object_method!\n", 1319 "Aborting" 1320 } 1321 1322 if(length $dir and not -d $dir) { 1323 DEBUG > 3 and print " No dir $dir -- skipping.\n"; 1324 return ""; 1325 } 1326 1327 if ($self->opt_m) { 1328 return $self->minus_f_nocase($dir,$file); 1329 } 1330 1331 else { 1332 my $path = $self->minus_f_nocase($dir,$file); 1333 if( length $path and $self->containspod($path) ) { 1334 DEBUG > 3 and print 1335 " The file $path indeed looks promising!\n"; 1336 return $path; 1337 } 1338 } 1339 DEBUG > 3 and print " No good: $file in $dir\n"; 1340 1341 return ""; 1342} 1343 1344#.......................................................................... 1345 1346sub containspod { 1347 my($self, $file, $readit) = @_; 1348 return 1 if !$readit && $file =~ /\.pod\z/i; 1349 1350 1351 # Under cygwin the /usr/bin/perl is legal executable, but 1352 # you cannot open a file with that name. It must be spelled 1353 # out as "/usr/bin/perl.exe". 1354 # 1355 # The following if-case under cygwin prevents error 1356 # 1357 # $ perldoc perl 1358 # Cannot open /usr/bin/perl: no such file or directory 1359 # 1360 # This would work though 1361 # 1362 # $ perldoc perl.pod 1363 1364 if ( IS_Cygwin and -x $file and -f "$file.exe" ) 1365 { 1366 warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v; 1367 return 0; 1368 } 1369 1370 local($_); 1371 open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism 1372 while (<TEST>) { 1373 if (/^=head/) { 1374 close(TEST) or die "Can't close $file: $!"; 1375 return 1; 1376 } 1377 } 1378 close(TEST) or die "Can't close $file: $!"; 1379 return 0; 1380} 1381 1382#.......................................................................... 1383 1384sub maybe_diddle_INC { 1385 my $self = shift; 1386 1387 # Does this look like a module or extension directory? 1388 1389 if (-f "Makefile.PL") { 1390 1391 # Add "." and "lib" to @INC (if they exist) 1392 eval q{ use lib qw(. lib); 1; } or die; 1393 1394 # don't add if superuser 1395 if ($< && $> && -f "blib") { # don't be looking too hard now! 1396 eval q{ use blib; 1 }; 1397 warn $@ if $@ && $self->opt_v; 1398 } 1399 } 1400 1401 return; 1402} 1403 1404#.......................................................................... 1405 1406sub new_output_file { 1407 my $self = shift; 1408 my $outspec = $self->opt_d; # Yes, -d overrides all else! 1409 # So don't call this twice per format-job! 1410 1411 return $self->new_tempfile(@_) unless defined $outspec and length $outspec; 1412 1413 # Otherwise open a write-handle on opt_d!f 1414 1415 my $fh; 1416 # If we are running before perl5.6.0, we can't autovivify 1417 if ($] < 5.006) { 1418 require Symbol; 1419 $fh = Symbol::gensym(); 1420 } 1421 DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; 1422 die "Can't write-open $outspec: $!" 1423 unless open($fh, ">", $outspec); # XXX 5.6ism 1424 1425 DEBUG > 3 and print "Successfully opened $outspec\n"; 1426 binmode($fh) if $self->{'output_is_binary'}; 1427 return($fh, $outspec); 1428} 1429 1430#.......................................................................... 1431 1432sub useful_filename_bit { 1433 # This tries to provide a meaningful bit of text to do with the query, 1434 # such as can be used in naming the file -- since if we're going to be 1435 # opening windows on temp files (as a "pager" may well do!) then it's 1436 # better if the temp file's name (which may well be used as the window 1437 # title) isn't ALL just random garbage! 1438 # In other words "perldoc_LWPSimple_2371981429" is a better temp file 1439 # name than "perldoc_2371981429". So this routine is what tries to 1440 # provide the "LWPSimple" bit. 1441 # 1442 my $self = shift; 1443 my $pages = $self->{'pages'} || return undef; 1444 return undef unless @$pages; 1445 1446 my $chunk = $pages->[0]; 1447 return undef unless defined $chunk; 1448 $chunk =~ s/:://g; 1449 $chunk =~ s/\.\w+$//g; # strip any extension 1450 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file 1451 $chunk = $1; 1452 } else { 1453 return undef; 1454 } 1455 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! 1456 $chunk = substr($chunk, -10) if length($chunk) > 10; 1457 return $chunk; 1458} 1459 1460#.......................................................................... 1461 1462sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) 1463 my $self = shift; 1464 1465 ++$Temp_Files_Created; 1466 1467 if( IS_MSWin32 ) { 1468 my @out = $self->MSWin_perldoc_tempfile(@_); 1469 return @out if @out; 1470 # otherwise fall thru to the normal stuff below... 1471 } 1472 1473 require File::Temp; 1474 return File::Temp::tempfile(UNLINK => 1); 1475} 1476 1477#.......................................................................... 1478 1479sub page { # apply a pager to the output file 1480 my ($self, $output, $output_to_stdout, @pagers) = @_; 1481 if ($output_to_stdout) { 1482 $self->aside("Sending unpaged output to STDOUT.\n"); 1483 open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism 1484 local $_; 1485 while (<TMP>) { 1486 print or die "Can't print to stdout: $!"; 1487 } 1488 close TMP or die "Can't close while $output: $!"; 1489 $self->unlink_if_temp_file($output); 1490 } else { 1491 # On VMS, quoting prevents logical expansion, and temp files with no 1492 # extension get the wrong default extension (such as .LIS for TYPE) 1493 1494 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; 1495 foreach my $pager (@pagers) { 1496 $self->aside("About to try calling $pager $output\n"); 1497 if (IS_VMS) { 1498 last if system("$pager $output") == 0; 1499 } else { 1500 last if system("$pager \"$output\"") == 0; 1501 } 1502 } 1503 } 1504 return; 1505} 1506 1507#.......................................................................... 1508 1509sub searchfor { 1510 my($self, $recurse,$s,@dirs) = @_; 1511 $s =~ s!::!/!g; 1512 $s = VMS::Filespec::unixify($s) if IS_VMS; 1513 return $s if -f $s && $self->containspod($s); 1514 $self->aside( "Looking for $s in @dirs\n" ); 1515 my $ret; 1516 my $i; 1517 my $dir; 1518 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? 1519 for ($i=0; $i<@dirs; $i++) { 1520 $dir = $dirs[$i]; 1521 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; 1522 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) 1523 or ( $ret = $self->check_file($dir,"$s.pm")) 1524 or ( $ret = $self->check_file($dir,$s)) 1525 or ( IS_VMS and 1526 $ret = $self->check_file($dir,"$s.com")) 1527 or ( IS_OS2 and 1528 $ret = $self->check_file($dir,"$s.cmd")) 1529 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and 1530 $ret = $self->check_file($dir,"$s.bat")) 1531 or ( $ret = $self->check_file("$dir/pod","$s.pod")) 1532 or ( $ret = $self->check_file("$dir/pod",$s)) 1533 or ( $ret = $self->check_file("$dir/pods","$s.pod")) 1534 or ( $ret = $self->check_file("$dir/pods",$s)) 1535 ) { 1536 DEBUG > 1 and print " Found $ret\n"; 1537 return $ret; 1538 } 1539 1540 if ($recurse) { 1541 opendir(D,$dir) or die "Can't opendir $dir: $!"; 1542 my @newdirs = map catfile($dir, $_), grep { 1543 not /^\.\.?\z/s and 1544 not /^auto\z/s and # save time! don't search auto dirs 1545 -d catfile($dir, $_) 1546 } readdir D; 1547 closedir(D) or die "Can't closedir $dir: $!"; 1548 next unless @newdirs; 1549 # what a wicked map! 1550 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; 1551 $self->aside( "Also looking in @newdirs\n" ); 1552 push(@dirs,@newdirs); 1553 } 1554 } 1555 return (); 1556} 1557 1558#.......................................................................... 1559{ 1560 my $already_asserted; 1561 sub assert_closing_stdout { 1562 my $self = shift; 1563 1564 return if $already_asserted; 1565 1566 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; 1567 # What for? to let the pager know that nothing more will come? 1568 1569 die $@ if $@; 1570 $already_asserted = 1; 1571 return; 1572 } 1573} 1574 1575#.......................................................................... 1576 1577sub tweak_found_pathnames { 1578 my($self, $found) = @_; 1579 if (IS_MSWin32) { 1580 foreach (@$found) { s,/,\\,g } 1581 } 1582 return; 1583} 1584 1585#.......................................................................... 1586# : : : : : : : : : 1587#.......................................................................... 1588 1589sub am_taint_checking { 1590 my $self = shift; 1591 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way 1592 my($k,$v) = each %ENV; 1593 return is_tainted($v); 1594} 1595 1596#.......................................................................... 1597 1598sub is_tainted { # just a function 1599 my $arg = shift; 1600 my $nada = substr($arg, 0, 0); # zero-length! 1601 local $@; # preserve the caller's version of $@ 1602 eval { eval "# $nada" }; 1603 return length($@) != 0; 1604} 1605 1606#.......................................................................... 1607 1608sub drop_privs_maybe { 1609 my $self = shift; 1610 1611 # Attempt to drop privs if we should be tainting and aren't 1612 if (!(IS_VMS || IS_MSWin32 || IS_Dos 1613 || IS_OS2 1614 ) 1615 && ($> == 0 || $< == 0) 1616 && !$self->am_taint_checking() 1617 ) { 1618 my $id = eval { getpwnam("nobody") }; 1619 $id = eval { getpwnam("nouser") } unless defined $id; 1620 $id = -2 unless defined $id; 1621 # 1622 # According to Stevens' APUE and various 1623 # (BSD, Solaris, HP-UX) man pages, setting 1624 # the real uid first and effective uid second 1625 # is the way to go if one wants to drop privileges, 1626 # because if one changes into an effective uid of 1627 # non-zero, one cannot change the real uid any more. 1628 # 1629 # Actually, it gets even messier. There is 1630 # a third uid, called the saved uid, and as 1631 # long as that is zero, one can get back to 1632 # uid of zero. Setting the real-effective *twice* 1633 # helps in *most* systems (FreeBSD and Solaris) 1634 # but apparently in HP-UX even this doesn't help: 1635 # the saved uid stays zero (apparently the only way 1636 # in HP-UX to change saved uid is to call setuid() 1637 # when the effective uid is zero). 1638 # 1639 eval { 1640 $< = $id; # real uid 1641 $> = $id; # effective uid 1642 $< = $id; # real uid 1643 $> = $id; # effective uid 1644 }; 1645 if( !$@ && $< && $> ) { 1646 DEBUG and print "OK, I dropped privileges.\n"; 1647 } elsif( $self->opt_U ) { 1648 DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." 1649 } else { 1650 DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; 1651 # We used to die here; but that seemed pointless. 1652 } 1653 } 1654 return; 1655} 1656 1657#.......................................................................... 1658 16591; 1660 1661__END__ 1662 1663# See "perldoc perldoc" for basic details. 1664# 1665# Perldoc -- look up a piece of documentation in .pod format that 1666# is embedded in the perl installation tree. 1667# 1668#~~~~~~ 1669# 1670# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. 1671# 1672# Version 3.01: Sun Nov 10 21:38:09 MST 2002 1673# Sean M. Burke <sburke@cpan.org> 1674# Massive refactoring and code-tidying. 1675# Now it's a module(-family)! 1676# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm 1677# Added -T, -d, -o, -M, -w. 1678# Added some improved MSWin funk. 1679# 1680#~~~~~~ 1681# 1682# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 1683# Hugo van der Sanden <hv@crypt.org> 1684# Made -U the default, based on patch from Simon Cozens 1685# Version 2.04: Sun Aug 18 13:27:12 BST 2002 1686# Randy W. Sims <RandyS@ThePierianSpring.org> 1687# allow -n to enable nroff under Win32 1688# Version 2.03: Sun Apr 23 16:56:34 BST 2000 1689# Hugo van der Sanden <hv@crypt.org> 1690# don't die when 'use blib' fails 1691# Version 2.02: Mon Mar 13 18:03:04 MST 2000 1692# Tom Christiansen <tchrist@perl.com> 1693# Added -U insecurity option 1694# Version 2.01: Sat Mar 11 15:22:33 MST 2000 1695# Tom Christiansen <tchrist@perl.com>, querulously. 1696# Security and correctness patches. 1697# What a twisted bit of distasteful spaghetti code. 1698# Version 2.0: ???? 1699# 1700#~~~~~~ 1701# 1702# Version 1.15: Tue Aug 24 01:50:20 EST 1999 1703# Charles Wilson <cwilson@ece.gatech.edu> 1704# changed /pod/ directory to /pods/ for cygwin 1705# to support cygwin/win32 1706# Version 1.14: Wed Jul 15 01:50:20 EST 1998 1707# Robin Barker <rmb1@cise.npl.co.uk> 1708# -strict, -w cleanups 1709# Version 1.13: Fri Feb 27 16:20:50 EST 1997 1710# Gurusamy Sarathy <gsar@activestate.com> 1711# -doc tweaks for -F and -X options 1712# Version 1.12: Sat Apr 12 22:41:09 EST 1997 1713# Gurusamy Sarathy <gsar@activestate.com> 1714# -various fixes for win32 1715# Version 1.11: Tue Dec 26 09:54:33 EST 1995 1716# Kenneth Albanowski <kjahds@kjahds.com> 1717# -added Charles Bailey's further VMS patches, and -u switch 1718# -added -t switch, with pod2text support 1719# 1720# Version 1.10: Thu Nov 9 07:23:47 EST 1995 1721# Kenneth Albanowski <kjahds@kjahds.com> 1722# -added VMS support 1723# -added better error recognition (on no found pages, just exit. On 1724# missing nroff/pod2man, just display raw pod.) 1725# -added recursive/case-insensitive matching (thanks, Andreas). This 1726# slows things down a bit, unfortunately. Give a precise name, and 1727# it'll run faster. 1728# 1729# Version 1.01: Tue May 30 14:47:34 EDT 1995 1730# Andy Dougherty <doughera@lafcol.lafayette.edu> 1731# -added pod documentation. 1732# -added PATH searching. 1733# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod 1734# and friends. 1735# 1736#~~~~~~~ 1737# 1738# TODO: 1739# 1740# Cache the directories read during sloppy match 1741# (To disk, or just in-memory?) 1742# 1743# Backport this to perl 5.005? 1744# 1745# Implement at least part of the "perlman" interface described 1746# in Programming Perl 3e? 1747