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