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