Re: perldoc, temp files, async pagers
[p5sagit/p5-mst-13.2.git] / utils / perldoc.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5
85880f03 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
4633a7c4 10# $startperl
85880f03 11# to ensure Configure will look for $Config{startperl}.
4633a7c4 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.
15chdir(dirname($0));
16($file = basename($0)) =~ s/\.PL$//;
17$file =~ s/\.pl$//
7eda7aea 18 if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4 19
20open OUT,">$file" or die "Can't create $file: $!";
21
22print "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
85880f03 27print OUT <<"!GROK!THIS!";
5f05dabc 28$Config{startperl}
29 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
30 if \$running_under_some_shell;
55497cff 31
32\@pagers = ();
33push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
4633a7c4 34!GROK!THIS!
35
36# In the following, perl variables are not expanded during extraction.
37
38print 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.
4633a7c4 47
48if(@ARGV<1) {
49 die <<EOF;
a2333f36 50Usage: $0 [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName
4633a7c4 51
52We suggest you use "perldoc perldoc" to get aquainted
53with the system.
54EOF
55}
56
57use Getopt::Std;
7eda7aea 58$Is_VMS = $^O eq 'VMS';
4633a7c4 59
60sub usage{
61 warn "@_\n" if @_;
36477c24 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';
4633a7c4 65 die <<EOF;
85880f03 66perldoc [-h] [-v] [-u] PageName|ModuleName|ProgramName...
4633a7c4 67 -h Display this help message.
85880f03 68 -t Display pod using pod2text instead of pod2man and nroff.
69 -u Display unformatted pod text
7eda7aea 70 -m Display modules file in its entirety
a2333f36 71 -l Display the modules file name
4633a7c4 72 -v Verbosely describe what's going on.
73PageName|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
80Any switches in the PERLDOC environment variable will be used before the
81command line arguments.
82
83EOF
84}
85
86use Text::ParseWords;
87
88
89unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
90
a2333f36 91getopts("mhtluv") || usage;
85880f03 92
93usage if $opt_h || $opt_h; # avoid -w warning
4633a7c4 94
a2333f36 95usage("only one of -t, -u, -m or -l") if $opt_t + $opt_u + $opt_m + $opt_l > 1;
4633a7c4 96
7eda7aea 97if ($opt_t) { require Pod::Text; import Pod::Text; }
4633a7c4 98
7eda7aea 99@pages = @ARGV;
85880f03 100
4633a7c4 101sub 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)){
9c9e9fb7 121 if (($Is_VMS or $^O eq 'os2') and not scalar @p) {
122 # VMSish filesystems don't begin at '/'
85880f03 123 push(@p,$p);
124 next;
125 }
4633a7c4 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)) {
85880f03 135 $cip =~ s/\.dir$// if $Is_VMS;
4633a7c4 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;
85880f03 153 $s = VMS::Filespec::unixify($s) if $Is_VMS;
4633a7c4 154 printf STDERR "looking for $s in @dirs\n" if $opt_v;
155 my $ret;
156 my $i;
157 my $dir;
88f0eda8 158
159 if (-f $s and containspod $s) {
160 return $s;
161 }
4633a7c4 162 for ($i=0;$i<@dirs;$i++) {
163 $dir = $dirs[$i];
85880f03 164 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
4633a7c4 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))
85880f03 168 or ( $Is_VMS and
169 $ret = minus_f_nocase "$dir/$s.com" and containspod($ret))
4633a7c4 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);
85880f03 178 @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
7eda7aea 179 next unless @newdirs;
4633a7c4 180 print STDERR "Also looking in @newdirs\n" if $opt_v;
181 push(@dirs,@newdirs);
182 }
183 }
184 return ();
185 }
186
187
188foreach (@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;
7eda7aea 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);
85880f03 203 }
4633a7c4 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 ) {
85880f03 214 print STDERR "Loosely found as @files\n" if $opt_v;
4633a7c4 215 } else {
216 print STDERR "No documentation found for '$_'\n";
217 }
218 }
219 push(@found,@files);
220}
221
222if(!@found) {
85880f03 223 exit ($Is_VMS ? 98962 : 1);
4633a7c4 224}
225
a2333f36 226if ($opt_l) {
227 print join("\n", @found), "\n";
228 exit;
229}
230
4633a7c4 231if( ! -t STDOUT ) { $opt_f = 1 }
232
85880f03 233unless($Is_VMS) {
4633a7c4 234 $tmp = "/tmp/perldoc1.$$";
55497cff 235 push @pagers, qw( more less pg view cat );
236 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
4633a7c4 237} else {
238 $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
55497cff 239 push @pagers, qw( most more less type/page );
4633a7c4 240}
7c36043d 241unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
4633a7c4 242
7eda7aea 243if ($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
4633a7c4 251foreach (@found) {
7eda7aea 252
85880f03 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");
40fc7247 259 if($^O =~ /hpux/) {
260 $rslt = `pod2man $_ | nroff -man | col -x`;
261 } else {
262 $rslt = `pod2man $_ | nroff -man`;
263 }
85880f03 264 if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
265 else { $err = $?; }
266 print TMP $rslt unless $err;
267 close TMP;
268 }
4633a7c4 269
85880f03 270 if( $opt_u or $err or -z $tmp) {
4633a7c4 271 open(OUT,">>$tmp");
272 open(IN,"<$_");
85880f03 273 $cut = 1;
274 while (<IN>) {
275 $cut = $1 eq 'cut' if /^=(\w+)/;
276 next if $cut;
277 print OUT;
278 }
4633a7c4 279 close(IN);
280 close(OUT);
281 }
282}
283
284if( $opt_f ) {
285 open(TMP,"<$tmp");
286 print while <TMP>;
287 close(TMP);
288} else {
85880f03 289 foreach $pager (@pagers) {
290 $sts = system("$pager $tmp");
291 last if $Is_VMS && ($sts & 1);
292 last unless $sts;
4633a7c4 293 }
294}
295
2961 while unlink($tmp); #Possibly pointless VMSism
297
298exit 0;
7eda7aea 299
300__END__
301
302=head1 NAME
303
304perldoc - Look up Perl documentation in pod format.
305
306=head1 SYNOPSIS
307
a2333f36 308B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName
7eda7aea 309
310=head1 DESCRIPTION
311
40fc7247 312I<perldoc> looks up a piece of documentation in .pod format that is embedded
313in the perl installation tree or in a perl script, and displays it via
314C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
315C<col -x> will be used.) This is primarily used for the documentation for
316the perl library modules.
7eda7aea 317
318Your system may also have man pages installed for those modules, in
319which 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
327Prints out a brief help message.
328
329=item B<-v> verbose
330
331Describes search for the item in detail.
332
333=item B<-t> text output
334
335Display docs using plain text converter, instead of nroff. This may be faster,
336but it won't look as nice.
337
338=item B<-u> unformatted
339
340Find docs only; skip reformatting by pod2*
341
342=item B<-m> module
343
344Display the entire module: both code and unformatted pod documentation.
345This may be useful if the docs don't explain a function in the detail
346you need, and you'd like to inspect the code directly; perldoc will find
347the file for you and simply hand it off for display.
348
a2333f36 349=item B<-l> file name only
350
351Display the file name of the module found.
352
7eda7aea 353=item B<PageName|ModuleName|ProgramName>
354
355The item you want to look up. Nested modules (such as C<File::Basename>)
356are specified either as C<File::Basename> or C<File/Basename>. You may also
357give a descriptive name of a page, such as C<perlfunc>. You make also give a
358partial or wrong-case name, such as "basename" for "File::Basename", but
359this will be slower, if there is more then one page with the same partial
360name, you will only get the first one.
361
362=back
363
364=head1 ENVIRONMENT
365
366Any switches in the C<PERLDOC> environment variable will be used before the
367command line arguments. C<perldoc> also searches directories
368specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
369defined) and C<PATH> environment variables.
370(The latter is so that embedded pods for executables, such as
371C<perldoc> itself, are available.)
372
373=head1 AUTHOR
374
375Kenneth Albanowski <kjahds@kjahds.com>
376
377Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
378
7eda7aea 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
4633a7c4 407!NO!SUBS!
408
409close OUT or die "Can't close $file: $!";
410chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
411exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';