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