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.004;    ## 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