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(@searchdirs,'perl_root:[lib.pod]')  # installed pods
 310             } else {
 311                 push(@searchdirs, grep(-d, split($Config{path_sep},
 312                                                  $ENV{'PATH'})));
 313             }
 314         }
 315         @files = searchfor(0,$_,@searchdirs);
 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 my $lines = $ENV{LINES} || 24;
 356
 357 if( ! -t STDOUT ) { $no_tty = 1 }
 358
 359 if ($Is_MSWin32) {
 360         $tmp = "$ENV{TEMP}\\perldoc1.$$";
 361         push @pagers, qw( more< less notepad );
 362         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 363 } elsif ($Is_VMS) {
 364         $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 365         push @pagers, qw( most more less type/page );
 366 } elsif ($Is_Dos) {
 367         $tmp = "$ENV{TEMP}/perldoc1.$$";
 368         $tmp =~ tr!\\/!//!s;
 369         push @pagers, qw( less.exe more.com< );
 370         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 371 } else {
 372         if ($^O eq 'os2') {
 373           require POSIX;
 374           $tmp = POSIX::tmpnam();
 375           unshift @pagers, 'less', 'cmd /c more <';
 376         } else {
 377           $tmp = "/tmp/perldoc1.$$";
 378         }
 379         push @pagers, qw( more less pg view cat );
 380         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 381 }
 382 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 383
 384 if ($opt_m) {
 385         foreach $pager (@pagers) {
 386                 system("$pager @found") or exit;
 387         }
 388         if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
 389         exit 1;
 390 }
 391
 392 if ($opt_f) {
 393    my $perlfunc = shift @found;
 394    open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
 395
 396    # Skip introduction
 397    while (<PFUNC>) {
 398        last if /^=head2 Alphabetical Listing of Perl Functions/;
 399    }
 400
 401    # Look for our function
 402    my $found = 0;
 403    my @pod;
 404    while (<PFUNC>) {
 405        if (/^=item\s+\Q$opt_f\E\b/o)  {
 406            $found = 1;
 407        } elsif (/^=item/) {
 408            last if $found > 1;
 409        }
 410        next unless $found;
 411        push @pod, $_;
 412        ++$found if /^\w/;       # found descriptive text
 413    }
 414    if (@pod) {
 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       } elsif (@pod < $lines-2) {
 462          print @pod;
 463       } else {
 464          foreach $pager (@pagers) {
 465             open (PAGER, "| $pager") or next;
 466             print PAGER @pod ;
 467             close(PAGER) or next;
 468             last;
 469          }
 470       }
 471    } else {
 472       die "No documentation for perl FAQ keyword `$opt_q' found\n";
 473    }
 474    exit;
 475 }
 476
 477 foreach (@found) {
 478
 479         if($opt_t) {
 480                 open(TMP,">>$tmp");
 481                 Pod::Text::pod2text($_,*TMP);
 482                 close(TMP);
 483         } elsif(not $opt_u) {
 484                 my $cmd = "pod2man --lax $_ | nroff -man";
 485                 $cmd .= " | col -x" if $^O =~ /hpux/;
 486                 $rslt = `$cmd`;
 487                 unless(($err = $?)) {
 488                         open(TMP,">>$tmp");
 489                         print TMP $rslt;
 490                         close TMP;
 491                 }
 492         }
 493
 494         if( $opt_u or $err or -z $tmp) {
 495                 open(OUT,">>$tmp");
 496                 open(IN,"<$_");
 497                 $cut = 1;
 498                 while (<IN>) {
 499                         $cut = $1 eq 'cut' if /^=(\w+)/;
 500                         next if $cut;
 501                         print OUT;
 502                 }
 503                 close(IN);
 504                 close(OUT);
 505         }
 506 }
 507
 508 if( $no_tty ) {
 509         open(TMP,"<$tmp");
 510         print while <TMP>;
 511         close(TMP);
 512 } else {
 513         foreach $pager (@pagers) {
 514                 system("$pager $tmp") or last;
 515         }
 516 }
 517
 518 1 while unlink($tmp); #Possibly pointless VMSism
 519
 520 exit 0;
 521
 522 __END__
 523
 524 =head1 NAME
 525
 526 perldoc - Look up Perl documentation in pod format.
 527
 528 =head1 SYNOPSIS
 529
 530 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
 531
 532 B<perldoc> B<-f> BuiltinFunction
 533
 534 B<perldoc> B<-q> FAQ Keyword
 535
 536 =head1 DESCRIPTION
 537
 538 I<perldoc> looks up a piece of documentation in .pod format that is embedded
 539 in the perl installation tree or in a perl script, and displays it via
 540 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
 541 C<col -x> will be used.) This is primarily used for the documentation for
 542 the perl library modules.
 543
 544 Your system may also have man pages installed for those modules, in
 545 which case you can probably just use the man(1) command.
 546
 547 =head1 OPTIONS
 548
 549 =over 5
 550
 551 =item B<-h> help
 552
 553 Prints out a brief help message.
 554
 555 =item B<-v> verbose
 556
 557 Describes search for the item in detail.
 558
 559 =item B<-t> text output
 560
 561 Display docs using plain text converter, instead of nroff. This may be faster,
 562 but it won't look as nice.
 563
 564 =item B<-u> unformatted
 565
 566 Find docs only; skip reformatting by pod2*
 567
 568 =item B<-m> module
 569
 570 Display the entire module: both code and unformatted pod documentation.
 571 This may be useful if the docs don't explain a function in the detail
 572 you need, and you'd like to inspect the code directly; perldoc will find
 573 the file for you and simply hand it off for display.
 574
 575 =item B<-l> file name only
 576
 577 Display the file name of the module found.
 578
 579 =item B<-F> file names
 580
 581 Consider arguments as file names, no search in directories will be performed.
 582
 583 =item B<-f> perlfunc
 584
 585 The B<-f> option followed by the name of a perl built in function will
 586 extract the documentation of this function from L<perlfunc>.
 587
 588 =item B<-q> perlfaq
 589
 590 The B<-q> option takes a regular expression as an argument.  It will search
 591 the question headings in perlfaq[1-9] and print the entries matching
 592 the regular expression.
 593
 594 =item B<-X> use an index if present
 595
 596 The B<-X> option looks for a entry whose basename matches the name given on the
 597 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
 598 contain fully qualified filenames, one per line.
 599
 600 =item B<PageName|ModuleName|ProgramName>
 601
 602 The item you want to look up.  Nested modules (such as C<File::Basename>)
 603 are specified either as C<File::Basename> or C<File/Basename>.  You may also
 604 give a descriptive name of a page, such as C<perlfunc>. You make also give a
 605 partial or wrong-case name, such as "basename" for "File::Basename", but
 606 this will be slower, if there is more then one page with the same partial
 607 name, you will only get the first one.
 608
 609 =back
 610
 611 =head1 ENVIRONMENT
 612
 613 Any switches in the C<PERLDOC> environment variable will be used before the
 614 command line arguments.  C<perldoc> also searches directories
 615 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 616 defined) and C<PATH> environment variables.
 617 (The latter is so that embedded pods for executables, such as
 618 C<perldoc> itself, are available.)  C<perldoc> will use, in order of
 619 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 620 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 621 used if C<perldoc> was told to display plain text or unformatted pod.)
 622
 623 =head1 AUTHOR
 624
 625 Kenneth Albanowski <kjahds@kjahds.com>
 626
 627 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 628
 629 =cut
 630
 631 #
 632 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
 633 #       Gurusamy Sarathy <gsar@umich.edu>
 634 #       -doc tweaks for -F and -X options
 635 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
 636 #       Gurusamy Sarathy <gsar@umich.edu>
 637 #       -various fixes for win32
 638 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 639 #       Kenneth Albanowski <kjahds@kjahds.com>
 640 #   -added Charles Bailey's further VMS patches, and -u switch
 641 #   -added -t switch, with pod2text support
 642 #
 643 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 644 #               Kenneth Albanowski <kjahds@kjahds.com>
 645 #       -added VMS support
 646 #       -added better error recognition (on no found pages, just exit. On
 647 #        missing nroff/pod2man, just display raw pod.)
 648 #       -added recursive/case-insensitive matching (thanks, Andreas). This
 649 #        slows things down a bit, unfortunately. Give a precise name, and
 650 #        it'll run faster.
 651 #
 652 # Version 1.01: Tue May 30 14:47:34 EDT 1995
 653 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
 654 #   -added pod documentation.
 655 #   -added PATH searching.
 656 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
 657 #    and friends.
 658 #
 659 #
 660 # TODO:
 661 #
 662 #       Cache directories read during sloppy match
 663 !NO!SUBS!
 664
 665 close OUT or die "Can't close $file: $!";
 666 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 667 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 668 chdir $origdir;