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