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