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