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