This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
10da904665ba198c4d2ded41d077981e81a6ea26
[perl5.git] / lib / Pod / Find.pm
1 #############################################################################  
2 # Pod/Find.pm -- finds files containing POD documentation
3 #
4 # Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de>
5
6 # Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
7 # from Nick Ing-Simmon's PodToHtml). All rights reserved.
8 # This file is part of "PodParser". Pod::Find is free software;
9 # you can redistribute it and/or modify it under the same terms
10 # as Perl itself.
11 #############################################################################
12
13 package Pod::Find;
14
15 use vars qw($VERSION);
16 $VERSION = 0.11;   ## Current version of this package
17 require  5.005;    ## requires this Perl version or later
18
19 #############################################################################
20
21 =head1 NAME
22
23 Pod::Find - find POD documents in directory trees
24
25 =head1 SYNOPSIS
26
27   use Pod::Find qw(pod_find simplify_name);
28   my %pods = pod_find({ -verbose => 1, -inc => 1 });
29   foreach(keys %pods) {
30      print "found library POD `$pods{$_}' in $_\n";
31   }
32
33   print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
34
35 =head1 DESCRIPTION
36
37 B<Pod::Find> provides a function B<pod_find> that searches for POD
38 documents in a given set of files and directories. It returns a hash
39 with the file names as keys and the POD name as value. The POD name
40 is derived from the file name and its position in the directory tree.
41
42 E.g. when searching in F<$HOME/perl5lib>, the file
43 F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
44 whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
45 I<Myclass::Subclass>. The name information can be used for POD
46 translators.
47
48 Only text files containing at least one valid POD command are found.
49
50 A warning is printed if more than one POD file with the same POD name
51 is found, e.g. F<CPAN.pm> in different directories. This usually
52 indicates duplicate occurences of modules in the I<@INC> search path.
53
54 The function B<simplify_name> is equivalent to B<basename>, but also
55 strips Perl-like extensions (.pm, .pl, .pod).
56
57 Note that neither B<pod_find> nor B<simplify_name> are exported by
58 default so be sure to specify them in the B<use> statement if you need them:
59
60   use Pod::Find qw(pod_find simplify_name);
61
62 =head1 OPTIONS
63
64 The first argument for B<pod_find> may be a hash reference with options.
65 The rest are either directories that are searched recursively or files.
66 The POD names of files are the plain basenames with any Perl-like extension
67 (.pm, .pl, .pod) stripped.
68
69 =over 4
70
71 =item B<-verbose>
72
73 Print progress information while scanning.
74
75 =item B<-perl>
76
77 Apply Perl-specific heuristics to find the correct PODs. This includes
78 stripping Perl-like extensions, omitting subdirectories that are numeric
79 but do I<not> match the current Perl interpreter's version id, suppressing
80 F<site_perl> as a module hierarchy name etc.
81
82 =item B<-script>
83
84 Search for PODs in the current Perl interpreter's installation 
85 B<scriptdir>. This is taken from the local L<Config|Config> module.
86
87 =item B<-inc>
88
89 Search for PODs in the current Perl interpreter's I<@INC> paths.
90
91 =back
92
93 =head1 AUTHOR
94
95 Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>,
96 heavily borrowing code from Nick Ing-Simmons' PodToHtml.
97
98 =head1 SEE ALSO
99
100 L<Pod::Parser>, L<Pod::Checker>
101
102 =cut
103
104 use strict;
105 #use diagnostics;
106 use Exporter;
107 use File::Find;
108 use Cwd;
109
110 use vars qw(@ISA @EXPORT_OK $VERSION);
111 @ISA = qw(Exporter);
112 @EXPORT_OK = qw(&pod_find &simplify_name);
113
114 # package global variables
115 my $SIMPLIFY_RX;
116
117 # return a hash of the POD files found
118 # first argument may be a hashref (options),
119 # rest is a list of directories to search recursively
120 sub pod_find
121 {
122     my %opts;
123     if(ref $_[0]) {
124         %opts = %{shift()};
125     }
126
127     $opts{-verbose} ||= 0;
128     $opts{-perl}    ||= 0;
129
130     my (@search) = @_;
131
132     if($opts{-script}) {
133         require Config;
134         push(@search, $Config::Config{scriptdir});
135         $opts{-perl} = 1;
136     }
137
138     if($opts{-inc}) {
139         push(@search, grep($_ ne '.',@INC));
140         $opts{-perl} = 1;
141     }
142
143     if($opts{-perl}) {
144         require Config;
145         # this code simplifies the POD name for Perl modules:
146         # * remove "site_perl"
147         # * remove e.g. "i586-linux"
148         # * remove e.g. 5.00503
149         # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
150         $SIMPLIFY_RX =
151           qq!^(?i:site_perl/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
152
153     }
154
155     my %dirs_visited;
156     my %pods;
157     my %names;
158     my $pwd = cwd();
159
160     foreach my $try (@search) {
161         unless($try =~ m:^/:s) {
162             # make path absolute
163             $try = join('/',$pwd,$try);
164         }
165         $try =~ s:/\.?(?=/|\z)::; # simplify path
166         my $name;
167         if(-f $try) {
168             if($name = _check_and_extract_name($try, $opts{-verbose})) {
169                 _check_for_duplicates($try, $name, \%names, \%pods);
170             }
171             next;
172         }
173         my $root_rx = qq!^\Q$try\E/!;
174         File::Find::find( sub {
175             my $item = $File::Find::name;
176             if(-d) {
177                 if($dirs_visited{$item}) {
178                     warn "Directory '$item' already seen, skipping.\n"
179                         if($opts{-verbose});
180                     $File::Find::prune = 1;
181                     return;
182                 }
183                 else {
184                     $dirs_visited{$item} = 1;
185                 }
186                 if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
187                     $File::Find::prune = 1;
188                     warn "Perl $] version mismatch on $_, skipping.\n"
189                         if($opts{-verbose});
190                 }
191                 return;
192             }
193             if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
194                 _check_for_duplicates($item, $name, \%names, \%pods);
195             }
196         }, $try); # end of File::Find::find
197     }
198     chdir $pwd;
199     %pods;
200 }
201
202 sub _check_for_duplicates {
203     my ($file, $name, $names_ref, $pods_ref) = @_;
204     if($$names_ref{$name}) {
205         warn "Duplicate POD found (shadowing?): $name ($file)\n";
206         warn "    Already seen in ",
207             join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
208     }
209     else {
210         $$names_ref{$name} = 1;
211     }
212     $$pods_ref{$file} = $name;
213 }
214
215 sub _check_and_extract_name {
216     my ($file, $verbose, $root_rx) = @_;
217
218     # check extension or executable
219     unless($file =~ /\.(pod|pm|pl)\z/i || (-f $file && -x _ && -T _)) {
220         return undef;
221     }
222
223     # check for one line of POD
224     unless(open(POD,"<$file")) {
225         warn "Error: $file is unreadable: $!\n";
226         return undef;
227     }
228     local $/ = undef;
229     my $pod = <POD>;
230     close(POD);
231     unless($pod =~ /\n=(head\d|pod|over|item)\b/) {
232         warn "No POD in $file, skipping.\n"
233             if($verbose);
234         return;
235     }
236     undef $pod;
237
238     # strip non-significant path components
239     # _TODO_ what happens on e.g. Win32?
240     my $name = $file;
241     if(defined $root_rx) {
242         $name =~ s!$root_rx!!s;
243         $name =~ s!$SIMPLIFY_RX!!os if(defined $SIMPLIFY_RX);
244     }
245     else {
246         $name =~ s:^.*/::s;
247     }
248     $name =~ s/\.(pod|pm|pl)\z//i;
249     $name =~ s!/+!::!g;
250     $name;
251 }
252
253 # basic simplification of the POD name:
254 # basename & strip extension
255 sub simplify_name {
256     my ($str) = @_;
257     $str =~ s:^.*/::s;
258     $str =~ s:\.p([lm]|od)\z::i;
259     $str;
260 }
261
262 1;
263