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 ':'; |