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