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