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