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