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