[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/pod/ -> Perldoc.pm (source)

   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?


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1