utils/perldoc.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12
  13 # This forces PL files to create target in same directory as PL file.
  14 # This is so that make depend always knows where to find PL derivatives.
  15 chdir dirname($0);
  16 $file = basename($0, '.PL');
  17 $file .= '.com' if $^O eq 'VMS';
  18
  19 open OUT,">$file" or die "Can't create $file: $!";
  20
  21 print "Extracting $file (with variable substitutions)\n";
  22
  23 # In this section, perl variables will be expanded during extraction.
  24 # You can use $Config{...} to use Configure variables.
  25
  26 print OUT <<"!GROK!THIS!";
  27 $Config{startperl}
  28     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  29         if \$running_under_some_shell;
  30
  31 \@pagers = ();
  32 push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
  33 !GROK!THIS!
  34
  35 # In the following, perl variables are not expanded during extraction.
  36
  37 print OUT <<'!NO!SUBS!';
  38
  39 #
  40 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
  41 # is embedded in the perl installation tree.
  42 #
  43 # This is not to be confused with Tom Christianson's perlman, which is a
  44 # man replacement, written in perl. This perldoc is strictly for reading
  45 # the perl manuals, though it too is written in perl.
  46
  47 if(@ARGV<1) {
  48         $me = $0;               # Editing $0 is unportable
  49         $me =~ s,.*/,,;
  50         die <<EOF;
  51 Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
  52        $me -f PerlFunc
  53        $me -q FAQKeywords
  54
  55 The -h option prints more help.  Also try "perldoc perldoc" to get
  56 aquainted with the system.
  57 EOF
  58 }
  59
  60 use Getopt::Std;
  61 use Config '%Config';
  62
  63 @global_found = ();
  64 $global_target = "";
  65
  66 $Is_VMS = $^O eq 'VMS';
  67 $Is_MSWin32 = $^O eq 'MSWin32';
  68 $Is_Dos = $^O eq 'dos';
  69
  70 sub usage{
  71     warn "@_\n" if @_;
  72     # Erase evidence of previous errors (if any), so exit status is simple.
  73     $! = 0;
  74     die <<EOF;
  75 perldoc [options] PageName|ModuleName|ProgramName...
  76 perldoc [options] -f BuiltinFunction
  77 perldoc [options] -q FAQRegex
  78
  79 Options:
  80     -h   Display this help message
  81     -r   Recursive search (slow)
  82     -i   Ignore case
  83     -t   Display pod using pod2text instead of pod2man and nroff
  84              (-t is the default on win32)
  85     -u   Display unformatted pod text
  86     -m   Display module's file in its entirety
  87     -l   Display the module's file name
  88     -F   Arguments are file names, not modules
  89     -v   Verbosely describe what's going on
  90     -X   use index if present (looks for pod.idx at $Config{archlib})
  91
  92
  93 PageName|ModuleName...
  94          is the name of a piece of documentation that you want to look at. You
  95          may either give a descriptive name of the page (as in the case of
  96          `perlfunc') the name of a module, either like `Term::Info',
  97          `Term/Info', the partial name of a module, like `info', or
  98          `makemaker', or the name of a program, like `perldoc'.
  99
 100 BuiltinFunction
 101          is the name of a perl function.  Will extract documentation from
 102          `perlfunc'.
 103
 104 FAQRegex
 105          is a regex. Will search perlfaq[1-9] for and extract any
 106          questions that match.
 107
 108 Any switches in the PERLDOC environment variable will be used before the
 109 command line arguments.  The optional pod index file contains a list of
 110 filenames, one per line.
 111
 112 EOF
 113 }
 114
 115 use Text::ParseWords;
 116
 117
 118 unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
 119
 120 getopts("mhtluvriFf:Xq") || usage;
 121
 122 usage if $opt_h || $opt_h; # avoid -w warning
 123
 124 $podidx = "$Config{'archlib'}/pod.idx";
 125 $podidx = "" if $opt_X || !-f "pod.idx" && !-r _ && -M _ > 7;
 126
 127 if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
 128     usage("only one of -t, -u, -m or -l")
 129 } elsif ($Is_MSWin32 || $Is_Dos) {
 130     $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
 131 }
 132
 133 if ($opt_t) { require Pod::Text; import Pod::Text; }
 134
 135 if ($opt_f) {
 136    @pages = ("perlfunc");
 137 } elsif ($opt_q) {
 138    @pages = ("perlfaq1" .. "perlfaq9");
 139 } else {
 140    @pages = @ARGV;
 141 }
 142
 143 # Does this look like a module or extension directory?
 144 if (-f "Makefile.PL") {
 145         # Add ., lib and blib/* libs to @INC (if they exist)
 146         unshift(@INC, '.');
 147         unshift(@INC, 'lib') if -d 'lib';
 148         require ExtUtils::testlib;
 149 }
 150
 151
 152
 153 sub containspod {
 154     my($file, $readit) = @_;
 155     return 1 if !$readit && $file =~ /\.pod$/i;
 156     local($_);
 157     open(TEST,"<$file");
 158     while(<TEST>) {
 159         if(/^=head/) {
 160             close(TEST);
 161             return 1;
 162         }
 163     }
 164     close(TEST);
 165     return 0;
 166 }
 167
 168 sub minus_f_nocase {
 169      my($dir,$file) = @_;
 170      my $path = join('/',$dir,$file);
 171      return $path if -f $path and -r _;
 172      if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
 173         # on a case-forgiving file system or if case is important
 174         # that is it all we can do
 175         warn "Ignored $file: unreadable\n" if -f _;
 176         return '';
 177      }
 178      local *DIR;
 179      local($")="/";
 180      my @p = ($dir);
 181      my($p,$cip);
 182      foreach $p (split(/\//, $file)){
 183         my $try = "@p/$p";
 184         stat $try;
 185         if (-d _){
 186             push @p, $p;
 187             if ( $p eq $global_target) {
 188                 $tmp_path = join ('/', @p);
 189                 my $path_f = 0;
 190                 for (@global_found) {
 191                     $path_f = 1 if $_ eq $tmp_path;
 192                 }
 193                 push (@global_found, $tmp_path) unless $path_f;
 194                 print STDERR "Found as @p but directory\n" if $opt_v;
 195             }
 196         } elsif (-f _ && -r _) {
 197             return $try;
 198         } elsif (-f _) {
 199             warn "Ignored $try: unreadable\n";
 200         } else {
 201             my $found=0;
 202             my $lcp = lc $p;
 203             opendir DIR, "@p";
 204             while ($cip=readdir(DIR)) {
 205                 if (lc $cip eq $lcp){
 206                     $found++;
 207                     last;
 208                 }
 209             }
 210             closedir DIR;
 211             return "" unless $found;
 212             push @p, $cip;
 213             return "@p" if -f "@p" and -r _;
 214             warn "Ignored $file: unreadable\n" if -f _;
 215         }
 216      }
 217      return "";
 218 }
 219
 220
 221 sub check_file {
 222     my($dir,$file) = @_;
 223     if ($opt_m) {
 224         return minus_f_nocase($dir,$file);
 225     } else {
 226         my $path = minus_f_nocase($dir,$file);
 227         return $path if containspod($path);
 228     }
 229     return "";
 230 }
 231
 232
 233 sub searchfor {
 234     my($recurse,$s,@dirs) = @_;
 235     $s =~ s!::!/!g;
 236     $s = VMS::Filespec::unixify($s) if $Is_VMS;
 237     return $s if -f $s && containspod($s);
 238     printf STDERR "Looking for $s in @dirs\n" if $opt_v;
 239     my $ret;
 240     my $i;
 241     my $dir;
 242     $global_target = (split('/', $s))[-1];
 243     for ($i=0; $i<@dirs; $i++) {
 244         $dir = $dirs[$i];
 245         ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
 246         if (       ( $ret = check_file $dir,"$s.pod")
 247                 or ( $ret = check_file $dir,"$s.pm")
 248                 or ( $ret = check_file $dir,$s)
 249                 or ( $Is_VMS and
 250                      $ret = check_file $dir,"$s.com")
 251                 or ( $^O eq 'os2' and
 252                      $ret = check_file $dir,"$s.cmd")
 253                 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
 254                      $ret = check_file $dir,"$s.bat")
 255                 or ( $ret = check_file "$dir/pod","$s.pod")
 256                 or ( $ret = check_file "$dir/pod",$s)
 257         ) {
 258             return $ret;
 259         }
 260
 261         if ($recurse) {
 262             opendir(D,$dir);
 263             my @newdirs = map "$dir/$_", grep {
 264                 not /^\.\.?$/ and
 265                 not /^auto$/  and   # save time! don't search auto dirs
 266                 -d  "$dir/$_"
 267             } readdir D;
 268             closedir(D);
 269             next unless @newdirs;
 270             @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
 271             print STDERR "Also looking in @newdirs\n" if $opt_v;
 272             push(@dirs,@newdirs);
 273         }
 274     }
 275     return ();
 276 }
 277
 278
 279 foreach (@pages) {
 280         if ($podidx && open(PODIDX, $podidx)) {
 281             my $searchfor = $_;
 282             local($_);
 283             $searchfor =~ s,::,/,g;
 284             print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
 285             while (<PODIDX>) {
 286                 chomp;
 287                 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
 288             }
 289             close(PODIDX);
 290             next;
 291         }
 292         print STDERR "Searching for $_\n" if $opt_v;
 293         # We must look both in @INC for library modules and in PATH
 294         # for executables, like h2xs or perldoc itself.
 295         @searchdirs = @INC;
 296         if ($opt_F) {
 297           next unless -r;
 298           push @found, $_ if $opt_m or containspod($_);
 299           next;
 300         }
 301         unless ($opt_m) {
 302             if ($Is_VMS) {
 303                 my($i,$trn);
 304                 for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
 305                     push(@searchdirs,$trn);
 306                 }
 307             push(@dirs,'perl_root:[lib.pod]')  # installed pods
 308             } else {
 309                 push(@searchdirs, grep(-d, split($Config{path_sep},
 310                                                  $ENV{'PATH'})));
 311             }
 312             @files= searchfor(0,$_,@searchdirs);
 313         }
 314         if( @files ) {
 315                 print STDERR "Found as @files\n" if $opt_v;
 316         } else {
 317                 # no match, try recursive search
 318
 319                 @searchdirs = grep(!/^\.$/,@INC);
 320
 321                 @files= searchfor(1,$_,@searchdirs) if $opt_r;
 322                 if( @files ) {
 323                         print STDERR "Loosely found as @files\n" if $opt_v;
 324                 } else {
 325                         print STDERR "No documentation found for \"$_\".\n";
 326                         if (@global_found) {
 327                             print STDERR "However, try\n";
 328                             my $dir = $file = "";
 329                             for $dir (@global_found) {
 330                                 opendir(DIR, $dir) or die "$!";
 331                                 while ($file = readdir(DIR)) {
 332                                     next if ($file =~ /^\./);
 333                                     $file =~ s/\.(pm|pod)$//;
 334                                     print STDERR "\tperldoc $_\::$file\n";
 335                                 }
 336                                 closedir DIR;
 337                             }
 338                         }
 339                 }
 340         }
 341         push(@found,@files);
 342 }
 343
 344 if(!@found) {
 345         exit ($Is_VMS ? 98962 : 1);
 346 }
 347
 348 if ($opt_l) {
 349     print join("\n", @found), "\n";
 350     exit;
 351 }
 352
 353 if( ! -t STDOUT ) { $no_tty = 1 }
 354
 355 if ($Is_MSWin32) {
 356         $tmp = "$ENV{TEMP}\\perldoc1.$$";
 357         push @pagers, qw( more< less notepad );
 358         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 359 } elsif ($Is_VMS) {
 360         $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 361         push @pagers, qw( most more less type/page );
 362 } elsif ($Is_Dos) {
 363         $tmp = "$ENV{TEMP}/perldoc1.$$";
 364         $tmp =~ tr!\\/!//!s;
 365         push @pagers, qw( less.exe more.com< );
 366         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 367 } else {
 368         if ($^O eq 'os2') {
 369           require POSIX;
 370           $tmp = POSIX::tmpnam();
 371           unshift @pagers, 'less', 'cmd /c more <';
 372         } else {
 373           $tmp = "/tmp/perldoc1.$$";
 374         }
 375         push @pagers, qw( more less pg view cat );
 376         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 377 }
 378 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 379
 380 if ($opt_m) {
 381         foreach $pager (@pagers) {
 382                 system("$pager @found") or exit;
 383         }
 384         if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
 385         exit 1;
 386 }
 387
 388 if ($opt_f) {
 389    my $perlfunc = shift @found;
 390    open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
 391
 392    # Skip introduction
 393    while (<PFUNC>) {
 394        last if /^=head2 Alphabetical Listing of Perl Functions/;
 395    }
 396
 397    # Look for our function
 398    my $found = 0;
 399    my @pod;
 400    while (<PFUNC>) {
 401        if (/^=item\s+\Q$opt_f\E\b/o)  {
 402            $found = 1;
 403        } elsif (/^=item/) {
 404            last if $found > 1;
 405        }
 406        next unless $found;
 407        push @pod, $_;
 408        ++$found if /^\w/;       # found descriptive text
 409    }
 410    if (@pod) {
 411         my $lines = $ENV{LINES} || 24;
 412
 413        if ($opt_t) {
 414            open(FORMATTER, "| pod2text") || die "Can't start filter";
 415            print FORMATTER "=over 8\n\n";
 416            print FORMATTER @pod;
 417            print FORMATTER "=back\n";
 418            close(FORMATTER);
 419        } elsif (@pod < $lines-2) {
 420            print @pod;
 421        } else {
 422            foreach $pager (@pagers) {
 423                 open (PAGER, "| $pager") or next;
 424                 print PAGER @pod ;
 425                 close(PAGER) or next;
 426                 last;
 427            }
 428        }
 429    } else {
 430        die "No documentation for perl function `$opt_f' found\n";
 431    }
 432    exit;
 433 }
 434
 435 if ($opt_q) {
 436    local @ARGV = @found;        # I'm lazy, sue me.
 437    my $found = 0;
 438    my %found_in;
 439    my @pod;
 440
 441    while (<>) {
 442       if (/^=head2\s+.*$opt_q/oi) {
 443          $found = 1;
 444          push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
 445       } elsif (/^=head2/) {
 446          $found = 0;
 447       }
 448       next unless $found;
 449       push @pod, $_;
 450    }
 451
 452    if (@pod) {
 453       if ($opt_t) {
 454          open(FORMATTER, "| pod2text") || die "Can't start filter";
 455          print FORMATTER "=over 8\n\n";
 456          print FORMATTER @pod;
 457          print FORMATTER "=back\n";
 458          close(FORMATTER);
 459       } else {
 460          print @pod;
 461       }
 462    } else {
 463       die "No documentation for perl function `$opt_f' found\n";
 464    }
 465    exit;
 466 }
 467
 468 foreach (@found) {
 469
 470         if($opt_t) {
 471                 open(TMP,">>$tmp");
 472                 Pod::Text::pod2text($_,*TMP);
 473                 close(TMP);
 474         } elsif(not $opt_u) {
 475                 my $cmd = "pod2man --lax $_ | nroff -man";
 476                 $cmd .= " | col -x" if $^O =~ /hpux/;
 477                 $rslt = `$cmd`;
 478                 unless(($err = $?)) {
 479                         open(TMP,">>$tmp");
 480                         print TMP $rslt;
 481                         close TMP;
 482                 }
 483         }
 484
 485         if( $opt_u or $err or -z $tmp) {
 486                 open(OUT,">>$tmp");
 487                 open(IN,"<$_");
 488                 $cut = 1;
 489                 while (<IN>) {
 490                         $cut = $1 eq 'cut' if /^=(\w+)/;
 491                         next if $cut;
 492                         print OUT;
 493                 }
 494                 close(IN);
 495                 close(OUT);
 496         }
 497 }
 498
 499 if( $no_tty ) {
 500         open(TMP,"<$tmp");
 501         print while <TMP>;
 502         close(TMP);
 503 } else {
 504         foreach $pager (@pagers) {
 505                 system("$pager $tmp") or last;
 506         }
 507 }
 508
 509 1 while unlink($tmp); #Possibly pointless VMSism
 510
 511 exit 0;
 512
 513 __END__
 514
 515 =head1 NAME
 516
 517 perldoc - Look up Perl documentation in pod format.
 518
 519 =head1 SYNOPSIS
 520
 521 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
 522
 523 B<perldoc> B<-f> BuiltinFunction
 524
 525 =head1 DESCRIPTION
 526
 527 I<perldoc> looks up a piece of documentation in .pod format that is embedded
 528 in the perl installation tree or in a perl script, and displays it via
 529 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
 530 C<col -x> will be used.) This is primarily used for the documentation for
 531 the perl library modules.
 532
 533 Your system may also have man pages installed for those modules, in
 534 which case you can probably just use the man(1) command.
 535
 536 =head1 OPTIONS
 537
 538 =over 5
 539
 540 =item B<-h> help
 541
 542 Prints out a brief help message.
 543
 544 =item B<-v> verbose
 545
 546 Describes search for the item in detail.
 547
 548 =item B<-t> text output
 549
 550 Display docs using plain text converter, instead of nroff. This may be faster,
 551 but it won't look as nice.
 552
 553 =item B<-u> unformatted
 554
 555 Find docs only; skip reformatting by pod2*
 556
 557 =item B<-m> module
 558
 559 Display the entire module: both code and unformatted pod documentation.
 560 This may be useful if the docs don't explain a function in the detail
 561 you need, and you'd like to inspect the code directly; perldoc will find
 562 the file for you and simply hand it off for display.
 563
 564 =item B<-l> file name only
 565
 566 Display the file name of the module found.
 567
 568 =item B<-F> file names
 569
 570 Consider arguments as file names, no search in directories will be performed.
 571
 572 =item B<-f> perlfunc
 573
 574 The B<-f> option followed by the name of a perl built in function will
 575 extract the documentation of this function from L<perlfunc>.
 576
 577 =item B<-X> use an index if present
 578
 579 The B<-X> option looks for a entry whose basename matches the name given on the
 580 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
 581 contain fully qualified filenames, one per line.
 582
 583 =item B<PageName|ModuleName|ProgramName>
 584
 585 The item you want to look up.  Nested modules (such as C<File::Basename>)
 586 are specified either as C<File::Basename> or C<File/Basename>.  You may also
 587 give a descriptive name of a page, such as C<perlfunc>. You make also give a
 588 partial or wrong-case name, such as "basename" for "File::Basename", but
 589 this will be slower, if there is more then one page with the same partial
 590 name, you will only get the first one.
 591
 592 =back
 593
 594 =head1 ENVIRONMENT
 595
 596 Any switches in the C<PERLDOC> environment variable will be used before the
 597 command line arguments.  C<perldoc> also searches directories
 598 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 599 defined) and C<PATH> environment variables.
 600 (The latter is so that embedded pods for executables, such as
 601 C<perldoc> itself, are available.)  C<perldoc> will use, in order of
 602 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 603 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 604 used if C<perldoc> was told to display plain text or unformatted pod.)
 605
 606 =head1 AUTHOR
 607
 608 Kenneth Albanowski <kjahds@kjahds.com>
 609
 610 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 611
 612 =cut
 613
 614 #
 615 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
 616 #       Gurusamy Sarathy <gsar@umich.edu>
 617 #       -doc tweaks for -F and -X options
 618 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
 619 #       Gurusamy Sarathy <gsar@umich.edu>
 620 #       -various fixes for win32
 621 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 622 #       Kenneth Albanowski <kjahds@kjahds.com>
 623 #   -added Charles Bailey's further VMS patches, and -u switch
 624 #   -added -t switch, with pod2text support
 625 #
 626 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 627 #               Kenneth Albanowski <kjahds@kjahds.com>
 628 #       -added VMS support
 629 #       -added better error recognition (on no found pages, just exit. On
 630 #        missing nroff/pod2man, just display raw pod.)
 631 #       -added recursive/case-insensitive matching (thanks, Andreas). This
 632 #        slows things down a bit, unfortunately. Give a precise name, and
 633 #        it'll run faster.
 634 #
 635 # Version 1.01: Tue May 30 14:47:34 EDT 1995
 636 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
 637 #   -added pod documentation.
 638 #   -added PATH searching.
 639 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
 640 #    and friends.
 641 #
 642 #
 643 # TODO:
 644 #
 645 #       Cache directories read during sloppy match
 646 !NO!SUBS!
 647
 648 close OUT or die "Can't close $file: $!";
 649 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 650 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';