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