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 shell variables you want Configure
   7 # to look for.
   8 #  $startperl
   9
  10 # This forces PL files to create target in same directory as PL file.
  11 # This is so that make depend always knows where to find PL derivatives.
  12 chdir(dirname($0));
  13 ($file = basename($0)) =~ s/\.PL$//;
  14 $file =~ s/\.pl$//
  15         if ($Config{'osname'} eq 'VMS' or
  16             $Config{'osname'} eq 'OS2');  # "case-forgiving"
  17
  18 open OUT,">$file" or die "Can't create $file: $!";
  19
  20 print "Extracting $file (with variable substitutions)\n";
  21
  22 # In this section, perl variables will be expanded during extraction.
  23 # You can use $Config{...} to use Configure variables.
  24
  25 print OUT <<"!GROK!THIS!";
  26 $Config{'startperl'}
  27     eval 'exec perl -S \$0 "\$@"'
  28         if 0;
  29 !GROK!THIS!
  30
  31 # In the following, perl variables are not expanded during extraction.
  32
  33 print OUT <<'!NO!SUBS!';
  34
  35 #
  36 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
  37 # is embedded in the perl installation tree.
  38 #
  39 # This is not to be confused with Tom Christianson's perlman, which is a
  40 # man replacement, written in perl. This perldoc is strictly for reading
  41 # the perl manuals, though it too is written in perl.
  42 #
  43 # Version 1.1: Thu Nov  9 07:23:47 EST 1995
  44 #               Kenneth Albanowski <kjahds@kjahds.com>
  45 #       -added VMS support
  46 #       -added better error recognition (on no found pages, just exit. On
  47 #        missing nroff/pod2man, just display raw pod.)
  48 #       -added recursive/case-insensitive matching (thanks, Andreas). This
  49 #        slows things down a bit, unfortunately. Give a precise name, and
  50 #        it'll run faster.
  51 #
  52 # Version 1.01: Tue May 30 14:47:34 EDT 1995
  53 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
  54 #   -added pod documentation.
  55 #   -added PATH searching.
  56 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
  57 #    and friends.
  58 #
  59 #
  60 # TODO:
  61 #
  62 #       Cache directories read during sloppy match
  63 #
  64
  65 =head1 NAME
  66
  67 perldoc - Look up Perl documentation in pod format.
  68
  69 =head1 SYNOPSIS
  70
  71 B<perldoc> [B<-h>] [B<-v>] PageName|ModuleName|ProgramName
  72
  73 =head1 DESCRIPTION
  74
  75 I<perldoc> looks up a piece of documentation in .pod format that is
  76 embedded in the perl installation tree or in a perl script, and displays
  77 it via pod2man | nroff -man | $PAGER.  This is primarily used for the
  78 documentation for the perl library modules.
  79
  80 Your system may also have man pages installed for those modules, in
  81 which case you can probably just use the man(1) command.
  82
  83 =head1 OPTIONS
  84
  85 =over 5
  86
  87 =item B<-h> help
  88
  89 Prints out a brief help message.
  90
  91 =item B<-v> verbose
  92
  93 Describes search for the item in detail.
  94
  95 =item B<PageName|ModuleName|ProgramName>
  96
  97 The item you want to look up.  Nested modules (such as C<File::Basename>)
  98 are specified either as C<File::Basename> or C<File/Basename>.  You may also
  99 give a descriptive name of a page, such as C<perlfunc>. You make also give a
 100 partial or wrong-case name, such as "basename" for "File::Basename", but
 101 this will be slower, if there is more then one page with the same partial
 102 name, you will only get the first one.
 103
 104 =back
 105
 106 =head1 ENVIRONMENT
 107
 108 Any switches in the C<PERLDOC> environment variable will be used before the
 109 command line arguments.  C<perldoc> also searches directories
 110 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 111 defined) and C<PATH> environment variables.
 112 (The latter is so that embedded pods for executables, such as
 113 C<perldoc> itself, are available.)
 114
 115 =head1 AUTHOR
 116
 117 Kenneth Albanowski <kjahds@kjahds.com>
 118
 119 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 120
 121 =head1 SEE ALSO
 122
 123 =head1 DIAGNOSTICS
 124
 125 =cut
 126
 127 if(@ARGV<1) {
 128         die <<EOF;
 129 Usage: $0 [-h] [-v] PageName|ModuleName|ProgramName
 130
 131 We suggest you use "perldoc perldoc" to get aquainted
 132 with the system.
 133 EOF
 134 }
 135
 136 use Getopt::Std;
 137
 138 sub usage{
 139         warn "@_\n" if @_;
 140     die <<EOF;
 141 perldoc [-h] [-v] PageName|ModuleName|ProgramName...
 142     -h   Display this help message.
 143     -v   Verbosely describe what's going on.
 144 PageName|ModuleName...
 145          is the name of a piece of documentation that you want to look at. You
 146          may either give a descriptive name of the page (as in the case of
 147          `perlfunc') the name of a module, either like `Term::Info',
 148          `Term/Info', the partial name of a module, like `info', or
 149          `makemaker', or the name of a program, like `perldoc'.
 150
 151 Any switches in the PERLDOC environment variable will be used before the
 152 command line arguments.
 153
 154 EOF
 155 }
 156
 157 use Text::ParseWords;
 158
 159
 160 unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
 161
 162 getopts("hv") || usage;
 163
 164 usage if $opt_h;
 165
 166 $index = $opt_i;
 167 @pages = @ARGV;
 168
 169 sub containspod {
 170         my($file) = @_;
 171         local($_);
 172         open(TEST,"<$file");
 173         while(<TEST>) {
 174                 if(/^=head/) {
 175                         close(TEST);
 176                         return 1;
 177                 }
 178         }
 179         close(TEST);
 180         return 0;
 181 }
 182
 183  sub minus_f_nocase {
 184      my($file) = @_;
 185      local *DIR;
 186      local($")="/";
 187      my(@p,$p,$cip);
 188      foreach $p (split(/\//, $file)){
 189         if (-d ("@p/$p")){
 190             push @p, $p;
 191         } elsif (-f ("@p/$p")) {
 192             return "@p/$p";
 193         } else {
 194             my $found=0;
 195             my $lcp = lc $p;
 196             opendir DIR, "@p";
 197             while ($cip=readdir(DIR)) {
 198                 if (lc $cip eq $lcp){
 199                     $found++;
 200                     last;
 201                 }
 202             }
 203             closedir DIR;
 204             return "" unless $found;
 205             push @p, $cip;
 206             return "@p" if -f "@p";
 207         }
 208      }
 209      return; # is not a file
 210  }
 211
 212   sub searchfor {
 213         my($recurse,$s,@dirs) = @_;
 214         $s =~ s!::!/!g;
 215         printf STDERR "looking for $s in @dirs\n" if $opt_v;
 216         my $ret;
 217         my $i;
 218         my $dir;
 219         for ($i=0;$i<@dirs;$i++) {
 220                 $dir = $dirs[$i];
 221             if ((    $ret = minus_f_nocase "$dir/$s.pod")
 222                 or ( $ret = minus_f_nocase "$dir/$s.pm"  and containspod($ret))
 223                 or ( $ret = minus_f_nocase "$dir/$s"     and containspod($ret))
 224                 or ( $ret = minus_f_nocase "$dir/pod/$s.pod")
 225                 or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret)))
 226                 { return $ret; }
 227
 228                 if($recurse) {
 229                         opendir(D,$dir);
 230                         my(@newdirs) = grep(-d,map("$dir/$_",grep(!/^\.\.?$/,readdir(D))));
 231                         closedir(D);
 232                         print STDERR "Also looking in @newdirs\n" if $opt_v;
 233                         push(@dirs,@newdirs);
 234                 }
 235         }
 236         return ();
 237   }
 238
 239
 240 foreach (@pages) {
 241         print STDERR "Searching for $_\n" if $opt_v;
 242         # We must look both in @INC for library modules and in PATH
 243         # for executables, like h2xs or perldoc itself.
 244         @searchdirs = @INC;
 245         push(@searchdirs, grep(-d, split(':', $ENV{'PATH'})));
 246         @files= searchfor(0,$_,@searchdirs);
 247         if( @files ) {
 248                 print STDERR "Found as @files\n" if $opt_v;
 249         } else {
 250                 # no match, try recursive search
 251
 252                 @searchdirs = grep(!/^\.$/,@INC);
 253
 254
 255                 @files= searchfor(1,$_,@searchdirs);
 256                 if( @files ) {
 257                         print STDERR "Loosly found as @files\n" if $opt_v;
 258                 } else {
 259                         print STDERR "No documentation found for '$_'\n";
 260                 }
 261         }
 262         push(@found,@files);
 263 }
 264
 265 if(!@found) {
 266         exit 1;
 267 }
 268
 269 $cmd=$filter="";
 270
 271 if( ! -t STDOUT ) { $opt_f = 1 }
 272
 273 require Config;
 274
 275 $VMS = $Config::Config{'osname'} eq "VMS";
 276
 277 unless($VMS) {
 278         $tmp = "/tmp/perldoc1.$$";
 279         $tmp2 = "/tmp/perldoc2.$$";
 280         $goodresult = 0;
 281 } else {
 282         $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 283         $tmp2 = 'Sys$Scratch:perldoc.tmp2_'.$$;
 284         $goodresult = 1;
 285 }
 286
 287 foreach (@found) {
 288
 289         open(TMP,">>$tmp");
 290         $rslt = `pod2man $_ | nroff -man`;
 291         if ($VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
 292         else      { $err = $?; }
 293         print TMP $rslt unless $err;
 294         close TMP;
 295
 296         1 while unlink($tmp2); # Possibly pointless VMSism
 297
 298         if( $err or -z $tmp) {
 299                 open(OUT,">>$tmp");
 300                 open(IN,"<$_");
 301                 print OUT while <IN>;
 302                 close(IN);
 303                 close(OUT);
 304         }
 305 }
 306
 307 if( $opt_f ) {
 308         open(TMP,"<$tmp");
 309         print while <TMP>;
 310         close(TMP);
 311 } else {
 312     pager:
 313     {
 314                 if( $ENV{PAGER} and system("$ENV{PAGER} $tmp")==$goodresult)
 315                         { last pager }
 316                 if( $Config{pager} and system("$Config{pager} $tmp")==$goodresult)
 317                         { last pager }
 318                 if( system("more $tmp")==$goodresult)
 319                         { last pager }
 320                 if( system("less $tmp")==$goodresult)
 321                         { last pager }
 322                 if( system("pg $tmp")==$goodresult)
 323                         { last pager }
 324                 if( system("view $tmp")==$goodresult)
 325                         { last pager }
 326         }
 327 }
 328
 329 1 while unlink($tmp); #Possibly pointless VMSism
 330
 331 exit 0;
 332 !NO!SUBS!
 333
 334 close OUT or die "Can't close $file: $!";
 335 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 336 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';