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