| Commit | Line | Data |
|---|
| 4633a7c4 |
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 ':'; |
projects / p5sagit/p5-mst-13.2.git / blame