1package Parse::LocalDistribution; 2 3use strict; 4use warnings; 5use Parse::PMFile; 6use List::Util (); 7use Parse::CPAN::Meta (); 8use File::Spec; 9use File::Find; 10use Cwd (); 11 12our $VERSION = '0.15'; 13 14sub new { 15 my ($class, $root, $opts) = @_; 16 if (ref $root eq ref {} && !$opts) { 17 $opts = $root; $root = undef; 18 } 19 $root ||= Cwd::cwd(); 20 bless {%{ $opts|| {} }, DISTROOT => $root, DIST => $root}, $class; 21} 22 23# adapted from PAUSE::mldistwatch#check_for_new 24sub parse { 25 my ($self, $root) = @_; 26 if ($root) { 27 $self->{DISTROOT} = $self->{DIST} = $root; 28 } 29 30 $self->_read_dist; 31 $self->_extract_meta; 32 $self->_examine_pms; 33} 34 35# from PAUSE::dist; 36sub _read_dist { 37 my $self = shift; 38 # TODO: support absolute path 39 my(@manifind) = $self->_find_files; 40 my $manifound = @manifind; 41 $self->{MANIFOUND} = \@manifind; 42 my $dist = $self->{DIST}; 43 unless (@manifind){ 44 $self->_verbose(1,"NO FILES! in dist $dist?"); 45 return; 46 } 47 $self->_verbose(1,"Found $manifound files in dist $dist, first $manifind[0]\n"); 48} 49 50# from PAUSE::dist; 51sub _extract_meta { 52 my $self = shift; 53 54 my $dist = $self->{DIST}; 55 my @manifind = @{$self->{MANIFOUND}}; 56 57 my $json = List::Util::reduce { length $a < length $b ? $a : $b } 58 grep !m|/t/|, grep m|/META\.json$|, @manifind; 59 my $yaml = List::Util::reduce { length $a < length $b ? $a : $b } 60 grep !m|/t/|, grep m|/META\.yml$|, @manifind; 61 62 # META.json located only in a subdirectory should not precede 63 # META.yml located in the top directory. (eg. Test::Module::Used 0.2.4) 64 if ($json && $yaml && length($json) > length($yaml) + 1) { 65 $json = ''; 66 } 67 68 unless ($json || $yaml) { 69 $self->{METAFILE} = "No META.yml or META.json found"; 70 $self->_verbose(1,"No META.yml or META.json in $dist"); 71 return; 72 } 73 74 for my $metafile ($json || $yaml) { 75 my $metafile_abs = File::Spec->catfile($self->{DISTROOT}, $metafile); 76 $metafile_abs =~ s|\\|/|g; 77 if (-s $metafile_abs) { 78 $self->{METAFILE} = $metafile; 79 my $ok = eval { 80 $self->{META_CONTENT} = Parse::CPAN::Meta->load_file($metafile_abs); 1 81 }; 82 unless ($ok) { 83 $self->_verbose(1,"Error while parsing $metafile: $@"); 84 $self->{META_CONTENT} = {}; 85 $self->{METAFILE} = "$metafile found but error " 86 . "encountered while loading: $@"; 87 } 88 } else { 89 $self->{METAFILE} = "Empty $metafile found, ignoring\n"; 90 } 91 } 92} 93 94# from PAUSE::dist; 95sub _examine_pms { 96 my $self = shift; 97 98 my $dist = $self->{DIST}; 99 100 my $pmfiles = $self->_filter_pms; 101 my($meta, $provides, $indexing_method); 102 if (my $version_from_meta_ok = $self->_version_from_meta_ok) { 103 $meta = $self->{META_CONTENT}; 104 $provides = $meta->{provides}; 105 if ($provides && "HASH" eq ref $provides) { 106 $indexing_method = '_index_by_meta'; 107 } 108 } 109 if (! $indexing_method && @$pmfiles) { # examine files 110 $indexing_method = '_index_by_files'; 111 } 112 113 if ($indexing_method) { 114 return $self->$indexing_method($pmfiles, $provides); 115 } 116 return {}; 117} 118 119# from PAUSE::dist 120sub _index_by_files { 121 my ($self, $pmfiles, $provides) = @_; 122 my $dist = $self->{DIST}; 123 124 my %result; 125 my $parser = Parse::PMFile->new($self->{META_CONTENT}, $self); 126 for my $pmfile (@$pmfiles) { 127 my $pmfile_abs = File::Spec->catfile($self->{DISTROOT}, $pmfile); 128 $pmfile_abs =~ s|\\|/|g; 129 if ($pmfile_abs =~ m|/blib/|) { 130 $self->_verbose(1,"Still a blib directory detected: 131 dist[$dist]pmfile[$pmfile] 132 "); 133 next; 134 } 135 136 my ($info, $errs) = $parser->parse($pmfile_abs); 137 138 for my $package (keys %$info) { 139 if (!defined $result{$package} or $info->{$package}{simile}) { 140 $result{$package} = $info->{$package}; 141 } 142 } 143 if ($errs) { 144 for my $package (keys %$errs) { 145 for (keys %{$errs->{$package}}) { 146 $result{$package}{$_ =~ /infile|warning/ ? $_ : $_.'_error'} = $errs->{$package}{$_}; 147 } 148 } 149 } 150 } 151 return \%result; 152} 153 154# from PAUSE::dist 155sub _index_by_meta { 156 my ($self, $pmfiles, $provides) = @_; 157 my $dist = $self->{DIST}; 158 159 my %result; 160 while (my($k,$v) = each %$provides) { 161 next if ref $v ne ref {}; 162 next if !defined $v->{file} or $v->{file} eq ''; 163 $v->{infile} = "$v->{file}"; 164 my @stat = stat File::Spec->catfile($self->{DISTROOT}, $v->{file}); 165 if (@stat) { 166 $v->{filemtime} = $stat[9]; 167 } else { 168 $v->{filemtime} = 0; 169 } 170 unless (defined $v->{version}) { 171 # 2009-09-23 get a bugreport due to 172 # RKITOVER/MooseX-Types-0.20.tar.gz not 173 # setting version for MooseX::Types::Util 174 $v->{version} = "undef"; 175 } 176 # going from a distro object to a package object 177 # is only possible via a file object 178 179 $self->_examine_pkg({package => $k, pp => $v}) or next; 180 181 $result{$k} = $v; 182 } 183 return \%result; 184} 185 186# from PAUSE::package; 187sub _examine_pkg { 188 my ($self, $args) = @_; 189 my $package = $args->{package}; 190 my $pp = $args->{pp}; 191 192 # should they be cought earlier? Maybe. 193 # but as an ultimate sanity check suggested by Richard Soderberg 194 # XXX should be in a separate sub and be tested 195 if ($package !~ /^\w[\w\:\']*\w?\z/ 196 || 197 $package !~ /\w\z/ 198 || 199 $package =~ /:/ && $package !~ /::/ 200 || 201 $package =~ /\w:\w/ 202 || 203 $package =~ /:::/ 204 ){ 205 $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check"); 206 return; 207 } 208 209 if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) { 210 return; 211 } 212 213 # No parser problem should be found 214 # (only used for META provides in this module) 215 216 # Sanity checks 217 218 for ( 219 $package, 220 $pp->{version}, 221 ) { 222 if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here 223 return; # don't screw up 02packages 224 } 225 } 226 $pp; 227} 228 229# from PAUSE::dist; 230sub _filter_pms { 231 my($self) = @_; 232 my @pmfile; 233 234 # very similar code is in PAUSE::package::filter_ppps 235 MANI: for my $mf ( @{$self->{MANIFOUND}} ) { 236 next unless $mf =~ /\.pm(?:\.PL)?$/i; 237 my($inmf) = $mf =~ m!^[^/]+/(.+)!; # go one directory down 238 239 # skip "t" - libraries in ./t are test libraries! 240 # skip "xt" - libraries in ./xt are author test libraries! 241 # skip "inc" - libraries in ./inc are usually install libraries 242 # skip "local" - somebody shipped his carton setup! 243 # skip 'perl5" - somebody shipped her local::lib! 244 # skip 'fatlib" - somebody shipped their fatpack lib! 245 next if $inmf =~ m!^(?:x?t|inc|local|perl5|fatlib)/!; 246 247 if ($self->{META_CONTENT}){ 248 my $no_index = $self->{META_CONTENT}{no_index} 249 || $self->{META_CONTENT}{private}; # backward compat 250 if (ref($no_index) eq 'HASH') { 251 my %map = ( 252 file => qr{\z}, 253 directory => qr{/}, 254 ); 255 for my $k (qw(file directory)) { 256 next unless my $v = $no_index->{$k}; 257 my $rest = $map{$k}; 258 if (ref $v eq "ARRAY") { 259 for my $ve (@$v) { 260 $ve =~ s|\\|/|g; # Class-InsideOut-0.90_01 261 $ve =~ s|/+$||; 262 if ($inmf =~ /^$ve$rest/){ 263 $self->_verbose(1,"Skipping inmf[$inmf] due to ve[$ve]"); 264 next MANI; 265 } else { 266 $self->_verbose(1,"NOT skipping inmf[$inmf] due to ve[$ve]"); 267 } 268 } 269 } else { 270 $v =~ s|/+$||; 271 if ($inmf =~ /^$v$rest/){ 272 $self->_verbose(1,"Skipping inmf[$inmf] due to v[$v]"); 273 next MANI; 274 } else { 275 $self->_verbose(1,"NOT skipping inmf[$inmf] due to v[$v]"); 276 } 277 } 278 } 279 } else { 280 # noisy: 281 # $self->_verbose(1,"no keyword 'no_index' or 'private' in META_CONTENT"); 282 } 283 } else { 284 # $self->_verbose(1,"no META_CONTENT"); # too noisy 285 } 286 push @pmfile, $mf; 287 } 288 $self->_verbose(1,"Finished with pmfile[@pmfile]\n"); 289 \@pmfile; 290} 291 292sub _version_from_meta_ok { Parse::PMFile::_version_from_meta_ok(@_) } 293sub _verbose { Parse::PMFile::_verbose(@_) } 294sub _perm_check { Parse::PMFile::_perm_check(@_) } 295 296# instead of ExtUtils::Manifest::manifind() 297# which only looks for files under the current directory. 298# We also need to look at MANIFEST/MANIFEST.SKIP here because 299# unwanted files are not excluded yet. 300# If we have MANIFEST, assume it's up-to-date and lists everything 301# we need. If we have only MANIFEST.SKIP, then look for files 302# and discard the matched. 303sub _find_files { 304 my $self = shift; 305 306 my @files = $self->_find_files_from_manifest; 307 return sort @files if @files; 308 309 my $skip = $self->_prepare_skip; 310 311 my $root = $self->{DISTROOT}; 312 my $wanted = sub { 313 my $name = $File::Find::name; 314 return if -d $_; 315 return if $name =~ m!/(?:\.(?:svn|git)|blib)/!; # too common 316 my $rel = File::Spec->abs2rel($name, $root); 317 $rel =~ s|\\|/|g; 318 return if $skip && $skip->($rel); 319 push @files, "./$rel"; 320 }; 321 322 File::Find::find( 323 {wanted => $wanted, follow => 0, no_chdir => 1}, $root 324 ); 325 326 return sort @files; 327} 328 329# adapted from ExtUtils::Manifest::maniread 330sub _find_files_from_manifest { 331 my $self = shift; 332 my $root = $self->{DISTROOT}; 333 my $manifile = "$root/MANIFEST"; 334 return unless -f $manifile; 335 336 my %files; 337 open my $fh, '<', $manifile or return; 338 while(<$fh>) { 339 next if /^\s*#/; 340 chomp; 341 my ($file, $comment); 342 if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) { 343 $file =~ s/\\([\\'])/$1/g; 344 } 345 else { 346 ($file, $comment) = /^(\S+)\s*(.*)/; 347 } 348 next unless $file; 349 $files{"./$file"} = $comment; 350 } 351 sort keys %files; 352} 353 354# adapted from ExtUtils::Manifest::maniskip 355sub _prepare_skip { 356 my $self = shift; 357 my $root = $self->{DISTROOT}; 358 my $skipfile = "$root/MANIFEST.SKIP"; 359 return unless -f $skipfile; 360 361 my @skip; 362 open my $fh, '<', $skipfile or return; 363 while(<$fh>) { 364 chomp; 365 s/\r//; 366 m{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; 367 my $filename = $2; 368 if ( defined($1) ) { 369 $filename = $1; 370 $filename =~ s/\\(['\\])/$1/g; 371 } 372 next if not defined($filename) or not $filename; 373 push @skip, $filename; 374 } 375 return unless @skip; 376 my $re = join '|', map "(?:$_)", @skip; 377 378 return sub {$_[0] =~ /$re/}; 379} 380 3811; 382 383__END__ 384 385=head1 NAME 386 387Parse::LocalDistribution - parses local .pm files as PAUSE does 388 389=head1 SYNOPSIS 390 391 use Parse::LocalDistribution; 392 393 my $parser = Parse::LocalDistribution->new({ALLOW_DEV_VERSION => 1}); 394 my $provides = $parser->parse('.'); 395 396=head1 DESCRIPTION 397 398This is a sister module of L<Parse::PMFile>. This module parses local .pm files (and a META file if any) in a specific (current if not specified) directory, and returns a hash reference that represents "provides" information (with some extra meta data). This is almost the same as L<Module::Metadata> does (which has been in Perl core since Perl 5.13.9). The main difference is the most of the code of this module is directly taken from the PAUSE code as of June 2013. If you need better compatibility to PAUSE, try this. If you need better performance, safety, or portability in general, L<Module::Metadata> may be a better and handier option (L<Parse::PMFile> (and thus L<Parse::LocalDistribution>) actually evaluates code in the $VERSION line (in a Safe compartment), which may be problematic in some cases). 399 400This module doesn't provide a feature to extract a distribution. If you are too lazy to implement it, L<CPAN::ParseDistribution> may be another good option. 401 402=head1 METHODS 403 404=head2 new 405 406creates an object. You can pass an optional path and/or an optional hashref to configure. Options are: 407 408=over 4 409 410=item ALLOW_DEV_VERSION 411 412Parse::LocalDistribution (actually L<Parse::PMFile>) usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis. 413 414=item VERBOSE 415 416Set this to true if you need to know some details. 417 418=item FORK 419 420If you really need to let Parse::PMFile fork while parsing a version (as PAUSE does), set this to true. 421 422=item USERID, PERMISSIONS 423 424Parse::LocalDistribution checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L<PAUSE::Permissions>) are provided. Unauthorized packages are removed. 425 426=back 427 428=head2 parse 429 430may take a path to a local distribution, and return a hash reference that holds information for package(s) found in the directory. 431 432=head1 SEE ALSO 433 434Most part of this module is derived from PAUSE. 435 436L<https://github.com/andk/pause> 437 438The following distributions do similar parsing, though the results may differ sometimes. 439 440L<Module::Metadata>, L<CPAN::ParseDistribution> 441 442=head1 AUTHOR 443 444Andreas Koenig E<lt>andreas.koenig@anima.deE<gt> 445 446Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt> 447 448=head1 COPYRIGHT AND LICENSE 449 450Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code. 451 452Copyright 2013 by Kenichi Ishigaki for some. 453 454This program is free software; you can redistribute it and/or 455modify it under the same terms as Perl itself. 456 457=cut 458