This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[win32] merge changes#872,873 from maintbranch
[perl5.git] / 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, '.PL');
17 $file .= '.com' if $^O eq 'VMS';
18
19 open OUT,">$file" or die "Can't create $file: $!";
20
21 print "Extracting $file (with variable substitutions)\n";
22
23 # In this section, perl variables will be expanded during extraction.
24 # You can use $Config{...} to use Configure variables.
25
26 print OUT <<"!GROK!THIS!";
27 $Config{startperl}
28     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
29         if \$running_under_some_shell;
30
31 \@pagers = ();
32 push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
33 !GROK!THIS!
34
35 # In the following, perl variables are not expanded during extraction.
36
37 print OUT <<'!NO!SUBS!';
38
39 #
40 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
41 # is embedded in the perl installation tree.
42 #
43 # This is not to be confused with Tom Christianson's perlman, which is a
44 # man replacement, written in perl. This perldoc is strictly for reading
45 # the perl manuals, though it too is written in perl.
46
47 if(@ARGV<1) {
48         $me = $0;               # Editing $0 is unportable
49         $me =~ s,.*/,,;
50         die <<EOF;
51 Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
52        $me -f PerlFunc
53        $me -q FAQKeywords
54
55 The -h option prints more help.  Also try "perldoc perldoc" to get
56 aquainted with the system.
57 EOF
58 }
59
60 use Getopt::Std;
61 use Config '%Config';
62
63 @global_found = ();
64 $global_target = "";
65
66 $Is_VMS = $^O eq 'VMS';
67 $Is_MSWin32 = $^O eq 'MSWin32';
68 $Is_Dos = $^O eq 'dos';
69
70 sub usage{
71     warn "@_\n" if @_;
72     # Erase evidence of previous errors (if any), so exit status is simple.
73     $! = 0;
74     die <<EOF;
75 perldoc [options] PageName|ModuleName|ProgramName...
76 perldoc [options] -f BuiltinFunction
77 perldoc [options] -q FAQRegex
78
79 Options:
80     -h   Display this help message
81     -t   Display pod using pod2text instead of pod2man and nroff
82              (-t is the default on win32)
83     -u   Display unformatted pod text
84     -m   Display module's file in its entirety
85     -l   Display the module's file name
86     -F   Arguments are file names, not modules
87     -v   Verbosely describe what's going on
88     -X   use index if present (looks for pod.idx at $Config{archlib})
89
90
91 PageName|ModuleName...
92          is the name of a piece of documentation that you want to look at. You 
93          may either give a descriptive name of the page (as in the case of
94          `perlfunc') the name of a module, either like `Term::Info', 
95          `Term/Info', the partial name of a module, like `info', or 
96          `makemaker', or the name of a program, like `perldoc'.
97
98 BuiltinFunction
99          is the name of a perl function.  Will extract documentation from
100          `perlfunc'.
101
102 FAQRegex
103          is a regex. Will search perlfaq[1-9] for and extract any
104          questions that match.
105
106 Any switches in the PERLDOC environment variable will be used before the 
107 command line arguments.  The optional pod index file contains a list of
108 filenames, one per line.
109
110 EOF
111 }
112
113 use Text::ParseWords;
114
115
116 unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
117
118 getopts("mhtluvFf:Xq:") || usage;
119
120 usage if $opt_h || $opt_h; # avoid -w warning
121
122 $podidx = "$Config{'archlib'}/pod.idx";
123 $podidx = "" if $opt_X || !-f "pod.idx" && !-r _ && -M _ > 7;
124
125 if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
126     usage("only one of -t, -u, -m or -l")
127 } elsif ($Is_MSWin32 || $Is_Dos) {
128     $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
129 }
130
131 if ($opt_t) { require Pod::Text; import Pod::Text; }
132
133 if ($opt_f) {
134    @pages = ("perlfunc");
135 } elsif ($opt_q) {
136    @pages = ("perlfaq1" .. "perlfaq9");
137 } else {
138    @pages = @ARGV;
139 }
140
141 # Does this look like a module or extension directory?
142 if (-f "Makefile.PL") {
143         # Add ., lib and blib/* libs to @INC (if they exist)
144         unshift(@INC, '.');
145         unshift(@INC, 'lib') if -d 'lib';
146         require ExtUtils::testlib;
147 }
148
149
150
151 sub containspod {
152     my($file, $readit) = @_;
153     return 1 if !$readit && $file =~ /\.pod$/i;
154     local($_);
155     open(TEST,"<$file");
156     while(<TEST>) {
157         if(/^=head/) {
158             close(TEST);
159             return 1;
160         }
161     }
162     close(TEST);
163     return 0;
164 }
165
166 sub minus_f_nocase {
167      my($file) = @_;
168      # on a case-forgiving file system we can simply use -f $file
169      if ($Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
170         return $file if -f $file and -r _;
171         warn "Ignored $file: unreadable\n" if -f _;
172         return '';
173      }
174      local *DIR;
175      local($")="/";
176      my(@p,$p,$cip);
177      foreach $p (split(/\//, $file)){
178         my $try = "@p/$p";
179         stat $try;
180         if (-d _){
181             push @p, $p;
182             if ( $p eq $global_target) {
183                 $tmp_path = join ('/', @p);
184                 my $path_f = 0;
185                 for (@global_found) {
186                     $path_f = 1 if $_ eq $tmp_path;
187                 }
188                 push (@global_found, $tmp_path) unless $path_f;
189                 print STDERR "Found as @p but directory\n" if $opt_v;
190             }
191         } elsif (-f _ && -r _) {
192             return $try;
193         } elsif (-f _) {
194             warn "Ignored $try: unreadable\n";
195         } else {
196             my $found=0;
197             my $lcp = lc $p;
198             opendir DIR, "@p";
199             while ($cip=readdir(DIR)) {
200                 if (lc $cip eq $lcp){
201                     $found++;
202                     last;
203                 }
204             }
205             closedir DIR;
206             return "" unless $found;
207             push @p, $cip;
208             return "@p" if -f "@p" and -r _;
209             warn "Ignored $file: unreadable\n" if -f _;
210         }
211      }
212      return; # is not a file
213 }
214  
215
216 sub check_file {
217     my($file) = @_;
218     $file = minus_f_nocase($file);
219         return "" unless $file;
220         return $file if $::opt_m;
221     return $file if containspod($file);
222     return "";
223 }
224
225
226 sub searchfor {
227     my($recurse,$s,@dirs) = @_;
228     $s =~ s!::!/!g;
229     $s = VMS::Filespec::unixify($s) if $Is_VMS;
230     return $s if -f $s && containspod($s);
231     printf STDERR "Looking for $s in @dirs\n" if $opt_v;
232     my $ret;
233     my $i;
234     my $dir;
235     $global_target = (split('/', $s))[-1];
236     for ($i=0; $i<@dirs; $i++) {
237         $dir = $dirs[$i];
238         ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
239         if (       ( $ret = check_file "$dir/$s.pod")
240                 or ( $ret = check_file "$dir/$s.pm")
241                 or ( $ret = check_file "$dir/$s")
242                 or ( $Is_VMS and
243                      $ret = check_file "$dir/$s.com")
244                 or ( $^O eq 'os2' and 
245                      $ret = check_file "$dir/$s.cmd")
246                 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
247                      $ret = check_file "$dir/$s.bat")
248                 or ( $ret = check_file "$dir/pod/$s.pod")
249                 or ( $ret = check_file "$dir/pod/$s")
250         ) {
251             return $ret;
252         }
253         
254         if ($recurse) {
255             opendir(D,$dir);
256             my @newdirs = map "$dir/$_", grep {
257                 not /^\.\.?$/ and
258                 not /^auto$/  and   # save time! don't search auto dirs
259                 -d  "$dir/$_"
260             } readdir D;
261             closedir(D);
262             next unless @newdirs;
263             @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
264             print STDERR "Also looking in @newdirs\n" if $opt_v;
265             push(@dirs,@newdirs);
266         }
267     }
268     return ();
269 }
270
271
272 foreach (@pages) {
273         if ($podidx && open(PODIDX, $podidx)) {
274             my $searchfor = $_;
275             local($_);
276             $searchfor =~ s,::,/,g;
277             print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
278             while (<PODIDX>) {
279                 chomp;
280                 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
281             }
282             close(PODIDX);
283             next;
284         }
285         print STDERR "Searching for $_\n" if $opt_v;
286         # We must look both in @INC for library modules and in PATH
287         # for executables, like h2xs or perldoc itself.
288         @searchdirs = @INC;
289         if ($opt_F) {
290           next unless -r;
291           push @found, $_ if $opt_m or containspod($_);
292           next;
293         }
294         unless ($opt_m) { 
295             if ($Is_VMS) {
296                 my($i,$trn);
297                 for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
298                     push(@searchdirs,$trn);
299                 }
300             push(@dirs,'perl_root:[lib.pod]')  # installed pods
301             } else {
302                 push(@searchdirs, grep(-d, split($Config{path_sep}, 
303                                                  $ENV{'PATH'})));
304             }
305             @files= searchfor(0,$_,@searchdirs);
306         }
307         if( @files ) {
308                 print STDERR "Found as @files\n" if $opt_v;
309         } else {
310                 # no match, try recursive search
311                 
312                 @searchdirs = grep(!/^\.$/,@INC);
313                 
314                 @files= searchfor(1,$_,@searchdirs);
315                 if( @files ) {
316                         print STDERR "Loosely found as @files\n" if $opt_v;
317                 } else {
318                         print STDERR "No documentation found for \"$_\".\n";
319                         if (@global_found) {
320                             print STDERR "However, try\n";
321                             my $dir = $file = "";
322                             for $dir (@global_found) {
323                                 opendir(DIR, $dir) or die "$!";
324                                 while ($file = readdir(DIR)) {
325                                     next if ($file =~ /^\./);
326                                     $file =~ s/\.(pm|pod)$//;
327                                     print STDERR "\tperldoc $_\::$file\n";
328                                 }
329                                 closedir DIR;
330                             }
331                         }
332                 }
333         }
334         push(@found,@files);
335 }
336
337 if(!@found) {
338         exit ($Is_VMS ? 98962 : 1);
339 }
340
341 if ($opt_l) {
342     print join("\n", @found), "\n";
343     exit;
344 }
345
346 if( ! -t STDOUT ) { $no_tty = 1 }
347
348 if ($Is_MSWin32) {
349         $tmp = "$ENV{TEMP}\\perldoc1.$$";
350         push @pagers, qw( more< less notepad );
351         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
352 } elsif ($Is_VMS) {
353         $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
354         push @pagers, qw( most more less type/page );
355 } elsif ($Is_Dos) {
356         $tmp = "$ENV{TEMP}/perldoc1.$$";
357         $tmp =~ tr!\\/!//!s;
358         push @pagers, qw( less.exe more.com< );
359         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
360 } else {
361         if ($^O eq 'os2') {
362           require POSIX;
363           $tmp = POSIX::tmpnam();
364         } else {
365           $tmp = "/tmp/perldoc1.$$";      
366         }
367         push @pagers, qw( more less pg view cat );
368         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
369 }
370 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
371
372 if ($opt_m) {
373         foreach $pager (@pagers) {
374                 system("$pager @found") or exit;
375         }
376         if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
377         exit 1;
378
379
380 if ($opt_f) {
381    my $perlfunc = shift @found;
382    open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
383
384    # Skip introduction
385    while (<PFUNC>) {
386        last if /^=head2 Alphabetical Listing of Perl Functions/;
387    }
388
389    # Look for our function
390    my $found = 0;
391    my @pod;
392    while (<PFUNC>) {
393        if (/^=item\s+\Q$opt_f\E\b/o)  {
394            $found = 1;
395        } elsif (/^=item/) {
396            last if $found > 1;
397        }
398        next unless $found;
399        push @pod, $_;
400        ++$found if /^\w/;       # found descriptive text
401    }
402    if (@pod) {
403         my $lines = $ENV{LINES} || 24;
404
405        if ($opt_t) {
406            open(FORMATTER, "| pod2text") || die "Can't start filter";
407            print FORMATTER "=over 8\n\n";
408            print FORMATTER @pod;
409            print FORMATTER "=back\n";
410            close(FORMATTER);
411        } elsif (@pod < $lines-2) {
412            print @pod;
413        } else {
414            foreach $pager (@pagers) {
415                 open (PAGER, "| $pager") or next;
416                 print PAGER @pod ;
417                 close(PAGER) or next;
418                 last;
419            }
420        }
421    } else {
422        die "No documentation for perl function `$opt_f' found\n";
423    }
424    exit;
425 }
426
427 if ($opt_q) {
428    local @ARGV = @found;        # I'm lazy, sue me.
429    my $found = 0;
430    my %found_in;
431    my @pod;
432
433    while (<>) {
434       if (/^=head2\s+.*$opt_q/oi) {
435          $found = 1;
436          push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
437       } elsif (/^=head2/) {
438          $found = 0;
439       }
440       next unless $found;
441       push @pod, $_;
442    }
443    
444    if (@pod) {
445       if ($opt_t) {
446          open(FORMATTER, "| pod2text") || die "Can't start filter";
447          print FORMATTER "=over 8\n\n";
448          print FORMATTER @pod;
449          print FORMATTER "=back\n";
450          close(FORMATTER);
451       } else {
452          print @pod;
453       }
454    } else {
455       die "No documentation for perl function `$opt_f' found\n";
456    }
457    exit;
458 }
459
460 foreach (@found) {
461
462         if($opt_t) {
463                 open(TMP,">>$tmp");
464                 Pod::Text::pod2text($_,*TMP);
465                 close(TMP);
466         } elsif(not $opt_u) {
467                 my $cmd = "pod2man --lax $_ | nroff -man";
468                 $cmd .= " | col -x" if $^O =~ /hpux/;
469                 $rslt = `$cmd`;
470                 unless(($err = $?)) {
471                         open(TMP,">>$tmp");
472                         print TMP $rslt;
473                         close TMP;
474                 }
475         }
476                                                         
477         if( $opt_u or $err or -z $tmp) {
478                 open(OUT,">>$tmp");
479                 open(IN,"<$_");
480                 $cut = 1;
481                 while (<IN>) {
482                         $cut = $1 eq 'cut' if /^=(\w+)/;
483                         next if $cut;
484                         print OUT;
485                 }
486                 close(IN);
487                 close(OUT);
488         }
489 }
490
491 if( $no_tty ) {
492         open(TMP,"<$tmp");
493         print while <TMP>;
494         close(TMP);
495 } else {
496         foreach $pager (@pagers) {
497                 system("$pager $tmp") or last;
498         }
499 }
500
501 1 while unlink($tmp); #Possibly pointless VMSism
502
503 exit 0;
504
505 __END__
506
507 =head1 NAME
508
509 perldoc - Look up Perl documentation in pod format.
510
511 =head1 SYNOPSIS
512
513 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
514
515 B<perldoc> B<-f> BuiltinFunction
516
517 =head1 DESCRIPTION
518
519 I<perldoc> looks up a piece of documentation in .pod format that is embedded
520 in the perl installation tree or in a perl script, and displays it via
521 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
522 C<col -x> will be used.) This is primarily used for the documentation for
523 the perl library modules.
524
525 Your system may also have man pages installed for those modules, in
526 which case you can probably just use the man(1) command.
527
528 =head1 OPTIONS
529
530 =over 5
531
532 =item B<-h> help
533
534 Prints out a brief help message.
535
536 =item B<-v> verbose
537
538 Describes search for the item in detail.
539
540 =item B<-t> text output
541
542 Display docs using plain text converter, instead of nroff. This may be faster,
543 but it won't look as nice.
544
545 =item B<-u> unformatted
546
547 Find docs only; skip reformatting by pod2*
548
549 =item B<-m> module
550
551 Display the entire module: both code and unformatted pod documentation.
552 This may be useful if the docs don't explain a function in the detail
553 you need, and you'd like to inspect the code directly; perldoc will find
554 the file for you and simply hand it off for display.
555
556 =item B<-l> file name only
557
558 Display the file name of the module found.
559
560 =item B<-F> file names
561
562 Consider arguments as file names, no search in directories will be performed.
563
564 =item B<-f> perlfunc
565
566 The B<-f> option followed by the name of a perl built in function will
567 extract the documentation of this function from L<perlfunc>.
568
569 =item B<-X> use an index if present
570
571 The B<-X> option looks for a entry whose basename matches the name given on the
572 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
573 contain fully qualified filenames, one per line.
574
575 =item B<PageName|ModuleName|ProgramName>
576
577 The item you want to look up.  Nested modules (such as C<File::Basename>)
578 are specified either as C<File::Basename> or C<File/Basename>.  You may also
579 give a descriptive name of a page, such as C<perlfunc>. You make also give a
580 partial or wrong-case name, such as "basename" for "File::Basename", but
581 this will be slower, if there is more then one page with the same partial
582 name, you will only get the first one.
583
584 =back
585
586 =head1 ENVIRONMENT
587
588 Any switches in the C<PERLDOC> environment variable will be used before the 
589 command line arguments.  C<perldoc> also searches directories
590 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
591 defined) and C<PATH> environment variables.
592 (The latter is so that embedded pods for executables, such as
593 C<perldoc> itself, are available.)  C<perldoc> will use, in order of
594 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
595 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
596 used if C<perldoc> was told to display plain text or unformatted pod.)
597
598 =head1 AUTHOR
599
600 Kenneth Albanowski <kjahds@kjahds.com>
601
602 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
603
604 =cut
605
606 #
607 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
608 #       Gurusamy Sarathy <gsar@umich.edu>
609 #       -doc tweaks for -F and -X options
610 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
611 #       Gurusamy Sarathy <gsar@umich.edu>
612 #       -various fixes for win32
613 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
614 #       Kenneth Albanowski <kjahds@kjahds.com>
615 #   -added Charles Bailey's further VMS patches, and -u switch
616 #   -added -t switch, with pod2text support
617
618 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
619 #               Kenneth Albanowski <kjahds@kjahds.com>
620 #       -added VMS support
621 #       -added better error recognition (on no found pages, just exit. On
622 #        missing nroff/pod2man, just display raw pod.)
623 #       -added recursive/case-insensitive matching (thanks, Andreas). This
624 #        slows things down a bit, unfortunately. Give a precise name, and
625 #        it'll run faster.
626 #
627 # Version 1.01: Tue May 30 14:47:34 EDT 1995
628 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
629 #   -added pod documentation.
630 #   -added PATH searching.
631 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
632 #    and friends.
633 #
634 #
635 # TODO:
636 #
637 #       Cache directories read during sloppy match
638 !NO!SUBS!
639
640 close OUT or die "Can't close $file: $!";
641 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
642 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';