utils/perldoc.PL

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