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