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 } else {
 238         $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 239         push @pagers, qw( most more less type/page );
 240 }
 241 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 242
 243 if ($opt_m) {
 244     foreach $pager (@pagers) {
 245         my($sts) = system("$pager @found");
 246         exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
 247     }
 248     exit $Is_VMS ? $sts : 1;
 249 }
 250
 251 foreach (@found) {
 252
 253         if($opt_t) {
 254                 open(TMP,">>$tmp");
 255                 Pod::Text::pod2text($_,*TMP);
 256                 close(TMP);
 257         } elsif(not $opt_u) {
 258                 open(TMP,">>$tmp");
 259                 if($^O =~ /hpux/) {
 260                         $rslt = `pod2man $_ | nroff -man | col -x`;
 261                 } else {
 262                         $rslt = `pod2man $_ | nroff -man`;
 263                 }
 264                 if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
 265                 else      { $err = $?; }
 266                 print TMP $rslt unless $err;
 267                 close TMP;
 268         }
 269
 270         if( $opt_u or $err or -z $tmp) {
 271                 open(OUT,">>$tmp");
 272                 open(IN,"<$_");
 273                 $cut = 1;
 274                 while (<IN>) {
 275                         $cut = $1 eq 'cut' if /^=(\w+)/;
 276                         next if $cut;
 277                         print OUT;
 278                 }
 279                 close(IN);
 280                 close(OUT);
 281         }
 282 }
 283
 284 if( $opt_f ) {
 285         open(TMP,"<$tmp");
 286         print while <TMP>;
 287         close(TMP);
 288 } else {
 289         foreach $pager (@pagers) {
 290                 $sts = system("$pager $tmp");
 291                 last if $Is_VMS && ($sts & 1);
 292                 last unless $sts;
 293         }
 294 }
 295
 296 1 while unlink($tmp); #Possibly pointless VMSism
 297
 298 exit 0;
 299
 300 __END__
 301
 302 =head1 NAME
 303
 304 perldoc - Look up Perl documentation in pod format.
 305
 306 =head1 SYNOPSIS
 307
 308 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName
 309
 310 =head1 DESCRIPTION
 311
 312 I<perldoc> looks up a piece of documentation in .pod format that is embedded
 313 in the perl installation tree or in a perl script, and displays it via
 314 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
 315 C<col -x> will be used.) This is primarily used for the documentation for
 316 the perl library modules.
 317
 318 Your system may also have man pages installed for those modules, in
 319 which case you can probably just use the man(1) command.
 320
 321 =head1 OPTIONS
 322
 323 =over 5
 324
 325 =item B<-h> help
 326
 327 Prints out a brief help message.
 328
 329 =item B<-v> verbose
 330
 331 Describes search for the item in detail.
 332
 333 =item B<-t> text output
 334
 335 Display docs using plain text converter, instead of nroff. This may be faster,
 336 but it won't look as nice.
 337
 338 =item B<-u> unformatted
 339
 340 Find docs only; skip reformatting by pod2*
 341
 342 =item B<-m> module
 343
 344 Display the entire module: both code and unformatted pod documentation.
 345 This may be useful if the docs don't explain a function in the detail
 346 you need, and you'd like to inspect the code directly; perldoc will find
 347 the file for you and simply hand it off for display.
 348
 349 =item B<-l> file name only
 350
 351 Display the file name of the module found.
 352
 353 =item B<PageName|ModuleName|ProgramName>
 354
 355 The item you want to look up.  Nested modules (such as C<File::Basename>)
 356 are specified either as C<File::Basename> or C<File/Basename>.  You may also
 357 give a descriptive name of a page, such as C<perlfunc>. You make also give a
 358 partial or wrong-case name, such as "basename" for "File::Basename", but
 359 this will be slower, if there is more then one page with the same partial
 360 name, you will only get the first one.
 361
 362 =back
 363
 364 =head1 ENVIRONMENT
 365
 366 Any switches in the C<PERLDOC> environment variable will be used before the
 367 command line arguments.  C<perldoc> also searches directories
 368 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 369 defined) and C<PATH> environment variables.
 370 (The latter is so that embedded pods for executables, such as
 371 C<perldoc> itself, are available.)
 372
 373 =head1 AUTHOR
 374
 375 Kenneth Albanowski <kjahds@kjahds.com>
 376
 377 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 378
 379 =cut
 380
 381 #
 382 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 383 #       Kenneth Albanowski <kjahds@kjahds.com>
 384 #   -added Charles Bailey's further VMS patches, and -u switch
 385 #   -added -t switch, with pod2text support
 386 #
 387 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 388 #               Kenneth Albanowski <kjahds@kjahds.com>
 389 #       -added VMS support
 390 #       -added better error recognition (on no found pages, just exit. On
 391 #        missing nroff/pod2man, just display raw pod.)
 392 #       -added recursive/case-insensitive matching (thanks, Andreas). This
 393 #        slows things down a bit, unfortunately. Give a precise name, and
 394 #        it'll run faster.
 395 #
 396 # Version 1.01: Tue May 30 14:47:34 EDT 1995
 397 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
 398 #   -added pod documentation.
 399 #   -added PATH searching.
 400 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
 401 #    and friends.
 402 #
 403 #
 404 # TODO:
 405 #
 406 #       Cache directories read during sloppy match
 407 !NO!SUBS!
 408
 409 close OUT or die "Can't close $file: $!";
 410 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 411 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';