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