File Coverage

inc/Module/Install/Metadata.pm
Criterion Covered Total %
statement 31 151 20.5
branch 6 70 8.5
condition 3 21 14.2
subroutine 7 27 25.9
pod 0 18 0.0
total 47 287 16.3


line stmt bran cond sub pod time code
1             #line 1
2             package Module::Install::Metadata;
3 1     1   8  
  1         2  
  1         41  
4 1     1   275 use strict 'vars';
  1         2  
  1         27  
5             use Module::Install::Base;
6 1     1   7  
  1         3  
  1         84  
7             use vars qw{$VERSION $ISCORE @ISA};
8 1     1   3 BEGIN {
9 1         2 $VERSION = '0.64';
10 1         9789 $ISCORE = 1;
11             @ISA = qw{Module::Install::Base};
12             }
13              
14             my @scalar_keys = qw{
15             name module_name abstract author version license
16             distribution_type perl_version tests
17             };
18              
19             my @tuple_keys = qw{
20             build_requires requires recommends bundles
21             };
22 0     0 0 0  
23 0     0 0 0 sub Meta { shift }
24 0     0 0 0 sub Meta_ScalarKeys { @scalar_keys }
25             sub Meta_TupleKeys { @tuple_keys }
26              
27             foreach my $key (@scalar_keys) {
28 6     6   5660 *$key = sub {
29 6 100 66     83 my $self = shift;
30 5         42 return $self->{values}{$key} if defined wantarray and !@_;
31 5         23 $self->{values}{$key} = shift;
32             return $self;
33             };
34             }
35              
36             foreach my $key (@tuple_keys) {
37 3     3   33 *$key = sub {
38 3 100       89 my $self = shift;
39             return $self->{values}{$key} unless @_;
40 1         10  
41 1         23 my @rv;
42 1 50       27 while (@_) {
43 1   50     13 my $module = shift or last;
44 1 50       13 my $version = shift || 0;
45 0         0 if ( $module eq 'perl' ) {
46 0         0 $version =~ s{^(\d+)\.(\d+)\.(\d+)}
47 0         0 {$1 + $2/1_000 + $3/1_000_000}e;
48 0         0 $self->perl_version($version);
49             next;
50 1         16 }
51 1         13 my $rv = [ $module, $version ];
52             push @rv, $rv;
53 1         8 }
  1         14  
54 1         7 push @{ $self->{values}{$key} }, @rv;
55             @rv;
56             };
57             }
58              
59 0     0 0 0 sub sign {
60 0 0 0     0 my $self = shift;
61 0 0       0 return $self->{'values'}{'sign'} if defined wantarray and !@_;
62 0         0 $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
63             return $self;
64             }
65              
66 0     0 0 0 sub dynamic_config {
67 0 0       0 my $self = shift;
68 0         0 unless ( @_ ) {
69 0         0 warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
70             return $self;
71 0 0       0 }
72 0         0 $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
73             return $self;
74             }
75              
76 0     0 0 0 sub all_from {
77             my ( $self, $file ) = @_;
78 0 0       0  
79 0 0       0 unless ( defined($file) ) {
80             my $name = $self->name
81 0         0 or die "all_from called with no args without setting name() first";
82 0 0       0 $file = join('/', 'lib', split(/-/, $name)) . '.pm';
83 0 0       0 $file =~ s{.*/}{} unless -e $file;
84             die "all_from: cannot find $file from $name" unless -e $file;
85             }
86 0 0       0  
87 0 0       0 $self->version_from($file) unless $self->version;
88             $self->perl_version_from($file) unless $self->perl_version;
89              
90             # The remaining probes read from POD sections; if the file
91 0         0 # has an accompanying .pod, use that instead
92 0 0 0     0 my $pod = $file;
93 0         0 if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
94             $file = $pod;
95             }
96 0 0       0  
97 0 0       0 $self->author_from($file) unless $self->author;
98 0 0       0 $self->license_from($file) unless $self->license;
99             $self->abstract_from($file) unless $self->abstract;
100             }
101              
102 0     0 0 0 sub provides {
103 0   0     0 my $self = shift;
104 0 0       0 my $provides = ( $self->{values}{provides} ||= {} );
105 0         0 %$provides = (%$provides, @_) if @_;
106             return $provides;
107             }
108              
109 0     0 0 0 sub auto_provides {
110 0 0       0 my $self = shift;
111             return $self unless $self->is_admin;
112 0 0       0  
113 0         0 unless (-e 'MANIFEST') {
114 0         0 warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
115             return $self;
116             }
117              
118             # Avoid spurious warnings as we are not checking manifest here.
119 0     0   0  
  0         0  
120 0         0 local $SIG{__WARN__} = sub {1};
121 0     0   0 require ExtUtils::Manifest;
  0         0  
122             local *ExtUtils::Manifest::manicheck = sub { return };
123 0         0  
124 0         0 require Module::Build;
125             my $build = Module::Build->new(
126             dist_name => $self->name,
127             dist_version => $self->version,
128             license => $self->license,
129 0 0       0 );
  0         0  
130             $self->provides(%{ $build->find_dist_packages || {} });
131             }
132              
133 0     0 0 0 sub feature {
134 0         0 my $self = shift;
135 0   0     0 my $name = shift;
136             my $features = ( $self->{values}{features} ||= [] );
137 0         0  
138             my $mods;
139 0 0 0     0  
140             if ( @_ == 1 and ref( $_[0] ) ) {
141             # The user used ->feature like ->features by passing in the second
142 0         0 # argument as a reference. Accomodate for that.
143             $mods = $_[0];
144 0         0 } else {
145             $mods = \@_;
146             }
147 0         0  
148 0 0       0 my $count = 0;
    0          
149             push @$features, (
150             $name => [
151 0         0 map {
152             ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
153             : @$_
154             : $_
155             } @$mods
156             ]
157             );
158 0         0  
159             return @$features;
160             }
161              
162 0     0 0 0 sub features {
163 0         0 my $self = shift;
164 0         0 while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
165             $self->feature( $name, @$mods );
166 0         0 }
167 0 0       0 return $self->{values}->{features}
168             ? @{ $self->{values}->{features} }
169             : ();
170             }
171              
172 0     0 0 0 sub no_index {
173 0         0 my $self = shift;
174 0 0       0 my $type = shift;
  0         0  
175 0         0 push @{ $self->{values}{no_index}{$type} }, @_ if $type;
176             return $self->{values}{no_index};
177             }
178              
179 0     0 0 0 sub read {
180 0         0 my $self = shift;
181             $self->include_deps( 'YAML', 0 );
182 0         0  
183 0         0 require YAML;
184             my $data = YAML::LoadFile('META.yml');
185              
186 0         0 # Call methods explicitly in case user has already set some values.
187 0 0       0 while ( my ( $key, $value ) = each %$data ) {
188 0 0       0 next unless $self->can($key);
189 0         0 if ( ref $value eq 'HASH' ) {
190 0         0 while ( my ( $module, $version ) = each %$value ) {
191             $self->can($key)->($self, $module => $version );
192             }
193             }
194 0         0 else {
195             $self->can($key)->($self, $value);
196             }
197 0         0 }
198             return $self;
199             }
200              
201 0     0 0 0 sub write {
202 0 0       0 my $self = shift;
203 0         0 return $self unless $self->is_admin;
204 0         0 $self->admin->write_meta;
205             return $self;
206             }
207              
208 1     1 0 20 sub version_from {
209 1         23 my ( $self, $file ) = @_;
210 1         38 require ExtUtils::MM_Unix;
211             $self->version( ExtUtils::MM_Unix->parse_version($file) );
212             }
213              
214 0     0 0   sub abstract_from {
215 0           my ( $self, $file ) = @_;
216 0           require ExtUtils::MM_Unix;
217             $self->abstract(
218             bless(
219             { DISTNAME => $self->name },
220             'ExtUtils::MM_Unix'
221             )->parse_abstract($file)
222             );
223             }
224              
225 0     0     sub _slurp {
226             my ( $self, $file ) = @_;
227 0            
228 0 0         local *FH;
229 0           open FH, "< $file" or die "Cannot open $file.pod: $!";
  0            
  0            
230             do { local $/; <FH> };
231             }
232              
233 0     0 0   sub perl_version_from {
234             my ( $self, $file ) = @_;
235 0 0          
236             if (
237             $self->_slurp($file) =~ m/
238             ^
239             use \s*
240             v?
241             ([\d_\.]+)
242             \s* ;
243             /ixms
244             )
245 0           {
246 0           my $v = $1;
247 0           $v =~ s{_}{}g;
248             $self->perl_version($1);
249             }
250 0           else {
251 0           warn "Cannot determine perl version info from $file\n";
252             return;
253             }
254             }
255              
256 0     0 0   sub author_from {
257 0           my ( $self, $file ) = @_;
258 0 0         my $content = $self->_slurp($file);
259             if ($content =~ m/
260             =head \d \s+ (?:authors?)\b \s*
261             ([^\n]*)
262             |
263             =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
264             .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
265             ([^\n]*)
266 0   0       /ixms) {
267 0           my $author = $1 || $2;
268 0           $author =~ s{E<lt>}{<}g;
269 0           $author =~ s{E<gt>}{>}g;
270             $self->author($author);
271             }
272 0           else {
273             warn "Cannot determine author info from $file\n";
274             }
275             }
276              
277 0     0 0   sub license_from {
278             my ( $self, $file ) = @_;
279 0 0          
280             if (
281             $self->_slurp($file) =~ m/
282             =head \d \s+
283             (?:licen[cs]e|licensing|copyright|legal)\b
284             (.*?)
285             (=head\\d.*|=cut.*|)
286             \z
287             /ixms
288             )
289 0           {
290 0           my $license_text = $1;
291             my @phrases = (
292             'under the same (?:terms|license) as perl itself' => 'perl',
293             'GNU public license' => 'gpl',
294             'GNU lesser public license' => 'gpl',
295             'BSD license' => 'bsd',
296             'Artistic license' => 'artistic',
297             'GPL' => 'gpl',
298             'LGPL' => 'lgpl',
299             'BSD' => 'bsd',
300             'Artistic' => 'artistic',
301 0           );
302 0           while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
303 0 0         $pattern =~ s{\s+}{\\s+}g;
304 0           if ( $license_text =~ /\b$pattern\b/i ) {
305 0           $self->license($license);
306             return 1;
307             }
308             }
309             }
310 0            
311 0           warn "Cannot determine license info from $file\n";
312             return 'unknown';
313             }
314              
315             1;