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