File Coverage

blib/lib/Distribution/Metadata.pm
Criterion Covered Total %
statement 41 242 16.9
branch 0 84 0.0
condition 0 42 0.0
subroutine 14 42 33.3
pod 14 14 100.0
total 69 424 16.2


line stmt bran cond sub pod time code
1             package Distribution::Metadata 0.10;
2 1     1   68485 use v5.16;
  1         4  
3 1     1   6 use warnings;
  1         2  
  1         29  
4              
5 1     1   480 use CPAN::DistnameInfo;
  1         987  
  1         66  
6 1     1   499 use CPAN::Meta;
  1         31104  
  1         31  
7 1     1   7 use Config ();
  1         2  
  1         34  
8 1     1   7 use Cwd ();
  1         2  
  1         16  
9 1     1   531 use ExtUtils::Packlist;
  1         1760  
  1         43  
10 1     1   10 use File::Basename ();
  1         3  
  1         16  
11 1     1   5 use File::Find ();
  1         2  
  1         14  
12 1     1   14 use File::Spec;
  1         2  
  1         18  
13 1     1   717 use JSON ();
  1         12895  
  1         35  
14 1     1   617 use Module::Metadata;
  1         5650  
  1         46  
15              
16 1     1   7 use constant DEBUG => $ENV{PERL_DISTRIBUTION_METADATA_DEBUG};
  1         2  
  1         2936  
17              
18             my $SEP = qr{/|\\}; # path separater
19             my $ARCHNAME = $Config::Config{archname};
20              
21             our $CACHE;
22              
23             sub new_from_file {
24 0     0 1   my ($class, $file, %option) = @_;
25 0           $class->_new(%option, _module => {file => $file});
26             }
27              
28             sub new_from_module {
29 0     0 1   my ($class, $module, %option) = @_;
30 0           $class->_new(%option, _module => {name => $module});
31             }
32              
33             sub _new {
34 0     0     my ($class, %option) = @_;
35 0           my $module = $option{_module};
36 0   0       my $inc = $option{inc} || \@INC;
37 0           $inc = $class->_abs_path($inc);
38 0 0         $inc = $class->_fill_archlib($inc) if $option{fill_archlib};
39             my $metadata = $module->{file}
40             ? Module::Metadata->new_from_file($module->{file}, inc => $inc)
41 0 0         : Module::Metadata->new_from_module($module->{name}, inc => $inc);
42              
43 0           my $self = bless {}, $class;
44 0 0         return $self unless $metadata;
45              
46 0           $module->{file} = $metadata->filename;
47 0           $module->{name} = $metadata->name;
48 0           $module->{version} = $metadata->version;
49              
50 0           my ($packlist, $files) = $class->_find_packlist($module->{file}, $inc);
51 0 0         if ($packlist) {
52 0           $self->{packlist} = $packlist;
53 0           $self->{files} = $files;
54             } else {
55 0           return $self;
56             }
57              
58 0           my ($main_module, $lib) = $self->_guess_main_module($packlist);
59 0 0         if ($main_module) {
60 0           $self->{main_module} = $main_module;
61 0 0         if ($main_module eq "perl") {
62 0           $self->{main_module_version} = $^V;
63 0           $self->{main_module_file} = $^X;
64 0           $self->{dist} = "perl";
65 0           my $version = "" . $^V;
66 0           $version =~ s/v//;
67 0           $self->{distvname} = "perl-$version";
68 0           $self->{version} = $version;
69 0           return $self;
70             }
71             } else {
72 0           return $self;
73             }
74              
75 0           my $archlib = File::Spec->catdir($lib, $ARCHNAME);
76 0           my $main_metadata = Module::Metadata->new_from_module(
77             $main_module, inc => [$archlib, $lib]
78             );
79              
80 0           my ($find_module, $find_version);
81 0 0         if ($main_metadata) {
82 0           $self->{main_module_version} = $main_metadata->version;
83 0           $self->{main_module_file} = $main_metadata->filename;
84 0           $find_module = $main_metadata->name;
85 0           $find_version = $main_metadata->version;
86             } else {
87 0           $find_module = $module->{name};
88 0           $find_version = $module->{version};
89             }
90              
91 0           my ($meta_directory, $install_json, $install_json_hash, $mymeta_json) = $class->_find_meta(
92             $main_module, $find_module, $find_version,
93             File::Spec->catdir($archlib, ".meta")
94             );
95 0           $self->{meta_directory} = $meta_directory;
96 0           $self->{install_json} = $install_json;
97 0           $self->{install_json_hash} = $install_json_hash;
98 0           $self->{mymeta_json} = $mymeta_json;
99 0           $self;
100             }
101              
102             sub _guess_main_module {
103 0     0     my ($self, $packlist) = @_;
104 0           my @piece = File::Spec->splitdir( File::Basename::dirname($packlist) );
105 0 0         if ($piece[-1] eq $ARCHNAME) {
106 0           return ("perl", undef);
107             }
108              
109 0           my (@module, @lib);
110 0           for my $i ( 1 .. ($#piece-2) ) {
111 0 0 0       if ($piece[$i] eq $ARCHNAME && $piece[$i+1] eq "auto") {
112 0           @module = @piece[ ($i+2) .. $#piece ];
113 0           @lib = @piece[ 0 .. ($i-1) ];
114 0           last;
115             }
116             }
117 0 0         return unless @module;
118 0           return ( _fix_module_name( join("::", @module) ), File::Spec->catdir(@lib) );
119             }
120              
121             # ugly workaround for case insensitive filesystem
122             # eg: if you install 'Version::Next' module and later 'version' module,
123             # then version's packlist is located at Version/.packlist! (capital V!)
124             # Maybe there are a lot of others...
125             my @fix_module_name = qw(version Version::Next);
126             sub _fix_module_name {
127 0     0     my $module_name = shift;
128 0 0         if (my ($fix) = grep { $module_name =~ /^$_$/i } @fix_module_name) {
  0            
129 0           $fix;
130             } else {
131 0           $module_name;
132             }
133             }
134              
135             sub _fill_archlib {
136 0     0     my ($class, $incs) = @_;
137 0           my %incs = map { $_ => 1 } @$incs;
  0            
138 0           my @out;
139 0           for my $inc (@$incs) {
140 0           push @out, $inc;
141 0 0         next if $inc =~ /$ARCHNAME$/o;
142 0           my $archlib = File::Spec->catdir($inc, $ARCHNAME);
143 0 0 0       if (-d $archlib && !$incs{$archlib}) {
144 0           push @out, $archlib;
145             }
146             }
147 0           \@out;
148             }
149              
150             my $decode_install_json = sub {
151             my $file = shift;
152             my $content = do { open my $fh, "<", $file or next; local $/; <$fh> };
153             JSON::decode_json($content);
154             };
155             sub _decode_install_json {
156 0     0     my ($class, $file, $dir) = @_;
157 0 0         if ($CACHE) {
158 0   0       $CACHE->{install_json}{$dir}{$file} ||= $decode_install_json->($file);
159             } else {
160 0           $decode_install_json->($file);
161             }
162             }
163              
164             sub _find_meta {
165 0     0     my ($class, $main_module, $module, $version, $dir) = @_;
166 0 0         return unless -d $dir;
167              
168 0           my @install_json;
169 0 0 0       if ($CACHE and $CACHE->{install_json_collected}{$dir}) {
170 0           @install_json = keys %{$CACHE->{install_json}{$dir}};
  0            
171             } else {
172 0           @install_json = do {
173 0 0         opendir my $dh, $dir or die "opendir $dir: $!";
174 0           my @meta_dir = grep { !/^[.]{1,2}$/ } readdir $dh;
  0            
175 0           grep -f, map { File::Spec->catfile($dir, $_, "install.json") } @meta_dir;
  0            
176             };
177 0 0         if ($CACHE) {
178 0   0       $CACHE->{install_json}{$dir}{$_} ||= undef for @install_json;
179 0           $CACHE->{install_json_collected}{$dir}++;
180             }
181             }
182              
183             # to speed up, first try distribution which just $module =~ s/::/-/gr;
184 0           my $naive = do { my $dist = $main_module; $dist =~ s/::/-/g; $dist };
  0            
  0            
  0            
185             @install_json = (
186 0           (sort { $b cmp $a } grep { /^$naive/ } @install_json),
  0            
187 0           (sort { $b cmp $a } grep { !/^$naive/ } @install_json),
  0            
  0            
188             );
189              
190 0           my ($meta_directory, $install_json, $install_json_hash, $mymeta_json);
191             INSTALL_JSON_LOOP:
192 0           for my $file (@install_json) {
193 0           my $hash = $class->_decode_install_json($file, $dir);
194              
195             # name VS target ? When LWP, name is LWP, and target is LWP::UserAgent
196             # So name is main_module!
197 0   0       my $name = $hash->{name} || "";
198 0 0         next if $name ne $main_module;
199 0   0       my $provides = $hash->{provides} || +{};
200 0           for my $provide (sort keys %$provides) {
201 0 0 0       if ($provide eq $module
      0        
202             && ($provides->{$provide}{version} || "") eq $version) {
203 0           $meta_directory = File::Basename::dirname($file);
204 0           $install_json = $file;
205 0           $mymeta_json = File::Spec->catfile($meta_directory, "MYMETA.json");
206 0           $install_json_hash = $hash;
207 0           last INSTALL_JSON_LOOP;
208             }
209             }
210 0           DEBUG and warn "==> failed to find $module $version in $file\n";
211             }
212              
213 0           return ($meta_directory, $install_json, $install_json_hash, $mymeta_json);
214             }
215              
216             sub _naive_packlist {
217 0     0     my ($class, $module_file, $inc) = @_;
218 0           for my $i (@$inc) {
219 0 0         if (my ($path) = $module_file =~ /$i $SEP (.+)\.pm /x) {
220 0 0         my $archlib = $i =~ /$ARCHNAME$/o ? $i : File::Spec->catdir($i, $ARCHNAME);
221 0           my $try = File::Spec->catfile( $archlib, "auto", $path, ".packlist" );
222 0 0         return $try if -f $try;
223             }
224             }
225 0           return;
226             }
227              
228             # It happens that .packlist files are symlink path.
229             # eg: OSX,
230             # in .packlist: /var/folders/...
231             # but /var/folders/.. is a symlink to /private/var/folders
232             my $extract_files = sub {
233             my $packlist = shift;
234             [
235             map { Cwd::abs_path($_) } grep { -f }
236             sort keys %{ ExtUtils::Packlist->new($packlist) || +{} }
237             ];
238             };
239             sub _extract_files {
240 0     0     my ($class, $packlist) = @_;
241 0 0         if ($CACHE) {
242 0   0       $CACHE->{packlist}{$packlist} ||= $extract_files->($packlist);
243             } else {
244 0           $extract_files->($packlist);
245             }
246             }
247              
248             sub _core_packlist {
249 0     0     my ($self, $inc) = @_;
250 0           for my $dir (grep -d, @$inc) {
251 0 0         opendir my $dh, $dir or die "Cannot open dir $dir: $!\n";
252 0           my ($packlist) = map { File::Spec->catfile($dir, $_) } grep {$_ eq ".packlist"} readdir $dh;
  0            
  0            
253 0 0         return $packlist if $packlist;
254             }
255 0           return;
256             }
257              
258             sub _find_packlist {
259 0     0     my ($class, $module_file, $inc) = @_;
260              
261 0 0 0       if ($CACHE and my $core_packlist = $CACHE->{core_packlist}) {
262 0           my $files = $class->_extract_files($core_packlist);
263 0 0         if (grep {$module_file eq $_} @$files) {
  0            
264 0           return ($core_packlist, $files);
265             }
266             }
267              
268             # to speed up, first try packlist which is naively guessed by $module_file
269 0 0         if (my $naive_packlist = $class->_naive_packlist($module_file, $inc)) {
270 0           my $files = $class->_extract_files($naive_packlist);
271 0 0         if ( grep { $module_file eq $_ } @$files ) {
  0            
272 0           DEBUG and warn "-> naively found packlist: $module_file\n";
273 0           return ($naive_packlist, $files);
274             }
275             }
276              
277 0           my @packlists;
278 0 0 0       if ($CACHE and $CACHE->{packlist_collected}) {
279 0           @packlists = keys %{ $CACHE->{packlist} };
  0            
280             } else {
281 0 0         if (my $core_packlist = $class->_core_packlist($inc)) {
282 0           push @packlists, $core_packlist;
283 0 0         $CACHE->{core_packlist} = $core_packlist if $CACHE;
284             }
285             File::Find::find sub {
286 0 0   0     return unless -f;
287 0 0         return unless $_ eq ".packlist";
288 0           push @packlists, $File::Find::name;
289 0           }, grep -d, map { File::Spec->catdir($_, "auto") } @{$class->_fill_archlib($inc)};
  0            
  0            
290 0 0         if ($CACHE) {
291 0   0       $CACHE->{packlist}{$_} ||= undef for @packlists;
292 0           $CACHE->{packlist_collected}++;
293             }
294             }
295              
296 0           for my $try (@packlists) {
297 0           my $files = $class->_extract_files($try);
298 0 0         if (grep { $module_file eq $_ } @$files) {
  0            
299 0           return ($try, $files);
300             }
301             }
302 0           return;
303             }
304              
305             sub _abs_path {
306 0     0     my ($class, $dirs) = @_;
307 0           my @out;
308 0           for my $dir (grep -d, @$dirs) {
309 0           my $abs = Cwd::abs_path($dir);
310 0           $abs =~ s/$SEP+$//;
311 0 0         push @out, $abs if $abs;
312             }
313 0           \@out;
314             }
315              
316 0     0 1   sub packlist { shift->{packlist} }
317 0     0 1   sub meta_directory { shift->{meta_directory} }
318 0     0 1   sub install_json { shift->{install_json} }
319 0     0 1   sub mymeta_json { shift->{mymeta_json} }
320 0     0 1   sub main_module { shift->{main_module} }
321 0     0 1   sub main_module_version { shift->{main_module_version} }
322 0     0 1   sub main_module_file { shift->{main_module_file} }
323 0     0 1   sub files { shift->{files} }
324 0     0 1   sub install_json_hash { shift->{install_json_hash} }
325              
326             sub mymeta_json_hash {
327 0     0 1   my $self = shift;
328 0 0         return unless my $mymeta_json = $self->mymeta_json;
329 0   0       $self->{mymeta_json_hash} ||= CPAN::Meta->load_file($mymeta_json)->as_struct;
330             }
331              
332             sub _distnameinfo {
333 0     0     my $self = shift;
334 0 0         return unless my $hash = $self->install_json_hash;
335 0   0       $self->{_distnameinfo} ||= CPAN::DistnameInfo->new( $hash->{pathname} );
336             }
337              
338             for my $attr (qw(dist version cpanid distvname pathname)) {
339 1     1   9 no strict 'refs';
  1         2  
  1         183  
340             *$attr = sub {
341 0     0     my $self = shift;
342 0 0         return $self->{$attr} if exists $self->{$attr}; # for 'perl' distribution
343 0 0         return unless $self->_distnameinfo;
344 0           $self->_distnameinfo->$attr;
345             };
346             }
347              
348             # alias
349 0     0 1   sub name { shift->dist }
350 0     0 1   sub author { shift->cpanid }
351              
352             1;
353              
354             __END__