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