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