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