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