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