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