add inc::Module::Install v0.91
[catagits/Catalyst-Engine-SCGI.git] / inc / Module / Install / Metadata.pm
CommitLineData
bc5a6228 1#line 1
2package Module::Install::Metadata;
3
4use strict 'vars';
5use Module::Install::Base ();
6
7use vars qw{$VERSION @ISA $ISCORE};
8BEGIN {
9 $VERSION = '0.91';
10 @ISA = 'Module::Install::Base';
11 $ISCORE = 1;
12}
13
14my @boolean_keys = qw{
15 sign
16};
17
18my @scalar_keys = qw{
19 name
20 module_name
21 abstract
22 author
23 version
24 distribution_type
25 tests
26 installdirs
27};
28
29my @tuple_keys = qw{
30 configure_requires
31 build_requires
32 requires
33 recommends
34 bundles
35 resources
36};
37
38my @resource_keys = qw{
39 homepage
40 bugtracker
41 repository
42};
43
44my @array_keys = qw{
45 keywords
46};
47
48sub Meta { shift }
49sub Meta_BooleanKeys { @boolean_keys }
50sub Meta_ScalarKeys { @scalar_keys }
51sub Meta_TupleKeys { @tuple_keys }
52sub Meta_ResourceKeys { @resource_keys }
53sub Meta_ArrayKeys { @array_keys }
54
55foreach my $key ( @boolean_keys ) {
56 *$key = sub {
57 my $self = shift;
58 if ( defined wantarray and not @_ ) {
59 return $self->{values}->{$key};
60 }
61 $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
62 return $self;
63 };
64}
65
66foreach my $key ( @scalar_keys ) {
67 *$key = sub {
68 my $self = shift;
69 return $self->{values}->{$key} if defined wantarray and !@_;
70 $self->{values}->{$key} = shift;
71 return $self;
72 };
73}
74
75foreach my $key ( @array_keys ) {
76 *$key = sub {
77 my $self = shift;
78 return $self->{values}->{$key} if defined wantarray and !@_;
79 $self->{values}->{$key} ||= [];
80 push @{$self->{values}->{$key}}, @_;
81 return $self;
82 };
83}
84
85foreach my $key ( @resource_keys ) {
86 *$key = sub {
87 my $self = shift;
88 unless ( @_ ) {
89 return () unless $self->{values}->{resources};
90 return map { $_->[1] }
91 grep { $_->[0] eq $key }
92 @{ $self->{values}->{resources} };
93 }
94 return $self->{values}->{resources}->{$key} unless @_;
95 my $uri = shift or die(
96 "Did not provide a value to $key()"
97 );
98 $self->resources( $key => $uri );
99 return 1;
100 };
101}
102
103foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
104 *$key = sub {
105 my $self = shift;
106 return $self->{values}->{$key} unless @_;
107 my @added;
108 while ( @_ ) {
109 my $module = shift or last;
110 my $version = shift || 0;
111 push @added, [ $module, $version ];
112 }
113 push @{ $self->{values}->{$key} }, @added;
114 return map {@$_} @added;
115 };
116}
117
118# Resource handling
119my %lc_resource = map { $_ => 1 } qw{
120 homepage
121 license
122 bugtracker
123 repository
124};
125
126sub resources {
127 my $self = shift;
128 while ( @_ ) {
129 my $name = shift or last;
130 my $value = shift or next;
131 if ( $name eq lc $name and ! $lc_resource{$name} ) {
132 die("Unsupported reserved lowercase resource '$name'");
133 }
134 $self->{values}->{resources} ||= [];
135 push @{ $self->{values}->{resources} }, [ $name, $value ];
136 }
137 $self->{values}->{resources};
138}
139
140# Aliases for build_requires that will have alternative
141# meanings in some future version of META.yml.
142sub test_requires { shift->build_requires(@_) }
143sub install_requires { shift->build_requires(@_) }
144
145# Aliases for installdirs options
146sub install_as_core { $_[0]->installdirs('perl') }
147sub install_as_cpan { $_[0]->installdirs('site') }
148sub install_as_site { $_[0]->installdirs('site') }
149sub install_as_vendor { $_[0]->installdirs('vendor') }
150
151sub dynamic_config {
152 my $self = shift;
153 unless ( @_ ) {
154 warn "You MUST provide an explicit true/false value to dynamic_config\n";
155 return $self;
156 }
157 $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
158 return 1;
159}
160
161sub perl_version {
162 my $self = shift;
163 return $self->{values}->{perl_version} unless @_;
164 my $version = shift or die(
165 "Did not provide a value to perl_version()"
166 );
167
168 # Normalize the version
169 $version = $self->_perl_version($version);
170
171 # We don't support the reall old versions
172 unless ( $version >= 5.005 ) {
173 die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
174 }
175
176 $self->{values}->{perl_version} = $version;
177}
178
179#Stolen from M::B
180my %license_urls = (
181 perl => 'http://dev.perl.org/licenses/',
182 apache => 'http://apache.org/licenses/LICENSE-2.0',
183 artistic => 'http://opensource.org/licenses/artistic-license.php',
184 artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
185 lgpl => 'http://opensource.org/licenses/lgpl-license.php',
186 lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
187 lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
188 bsd => 'http://opensource.org/licenses/bsd-license.php',
189 gpl => 'http://opensource.org/licenses/gpl-license.php',
190 gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
191 gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
192 mit => 'http://opensource.org/licenses/mit-license.php',
193 mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
194 open_source => undef,
195 unrestricted => undef,
196 restrictive => undef,
197 unknown => undef,
198);
199
200sub license {
201 my $self = shift;
202 return $self->{values}->{license} unless @_;
203 my $license = shift or die(
204 'Did not provide a value to license()'
205 );
206 $self->{values}->{license} = $license;
207
208 # Automatically fill in license URLs
209 if ( $license_urls{$license} ) {
210 $self->resources( license => $license_urls{$license} );
211 }
212
213 return 1;
214}
215
216sub all_from {
217 my ( $self, $file ) = @_;
218
219 unless ( defined($file) ) {
220 my $name = $self->name or die(
221 "all_from called with no args without setting name() first"
222 );
223 $file = join('/', 'lib', split(/-/, $name)) . '.pm';
224 $file =~ s{.*/}{} unless -e $file;
225 unless ( -e $file ) {
226 die("all_from cannot find $file from $name");
227 }
228 }
229 unless ( -f $file ) {
230 die("The path '$file' does not exist, or is not a file");
231 }
232
233 # Some methods pull from POD instead of code.
234 # If there is a matching .pod, use that instead
235 my $pod = $file;
236 $pod =~ s/\.pm$/.pod/i;
237 $pod = $file unless -e $pod;
238
239 # Pull the different values
240 $self->name_from($file) unless $self->name;
241 $self->version_from($file) unless $self->version;
242 $self->perl_version_from($file) unless $self->perl_version;
243 $self->author_from($pod) unless $self->author;
244 $self->license_from($pod) unless $self->license;
245 $self->abstract_from($pod) unless $self->abstract;
246
247 return 1;
248}
249
250sub provides {
251 my $self = shift;
252 my $provides = ( $self->{values}->{provides} ||= {} );
253 %$provides = (%$provides, @_) if @_;
254 return $provides;
255}
256
257sub auto_provides {
258 my $self = shift;
259 return $self unless $self->is_admin;
260 unless (-e 'MANIFEST') {
261 warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
262 return $self;
263 }
264 # Avoid spurious warnings as we are not checking manifest here.
265 local $SIG{__WARN__} = sub {1};
266 require ExtUtils::Manifest;
267 local *ExtUtils::Manifest::manicheck = sub { return };
268
269 require Module::Build;
270 my $build = Module::Build->new(
271 dist_name => $self->name,
272 dist_version => $self->version,
273 license => $self->license,
274 );
275 $self->provides( %{ $build->find_dist_packages || {} } );
276}
277
278sub feature {
279 my $self = shift;
280 my $name = shift;
281 my $features = ( $self->{values}->{features} ||= [] );
282 my $mods;
283
284 if ( @_ == 1 and ref( $_[0] ) ) {
285 # The user used ->feature like ->features by passing in the second
286 # argument as a reference. Accomodate for that.
287 $mods = $_[0];
288 } else {
289 $mods = \@_;
290 }
291
292 my $count = 0;
293 push @$features, (
294 $name => [
295 map {
296 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
297 } @$mods
298 ]
299 );
300
301 return @$features;
302}
303
304sub features {
305 my $self = shift;
306 while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
307 $self->feature( $name, @$mods );
308 }
309 return $self->{values}->{features}
310 ? @{ $self->{values}->{features} }
311 : ();
312}
313
314sub no_index {
315 my $self = shift;
316 my $type = shift;
317 push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
318 return $self->{values}->{no_index};
319}
320
321sub read {
322 my $self = shift;
323 $self->include_deps( 'YAML::Tiny', 0 );
324
325 require YAML::Tiny;
326 my $data = YAML::Tiny::LoadFile('META.yml');
327
328 # Call methods explicitly in case user has already set some values.
329 while ( my ( $key, $value ) = each %$data ) {
330 next unless $self->can($key);
331 if ( ref $value eq 'HASH' ) {
332 while ( my ( $module, $version ) = each %$value ) {
333 $self->can($key)->($self, $module => $version );
334 }
335 } else {
336 $self->can($key)->($self, $value);
337 }
338 }
339 return $self;
340}
341
342sub write {
343 my $self = shift;
344 return $self unless $self->is_admin;
345 $self->admin->write_meta;
346 return $self;
347}
348
349sub version_from {
350 require ExtUtils::MM_Unix;
351 my ( $self, $file ) = @_;
352 $self->version( ExtUtils::MM_Unix->parse_version($file) );
353}
354
355sub abstract_from {
356 require ExtUtils::MM_Unix;
357 my ( $self, $file ) = @_;
358 $self->abstract(
359 bless(
360 { DISTNAME => $self->name },
361 'ExtUtils::MM_Unix'
362 )->parse_abstract($file)
363 );
364}
365
366# Add both distribution and module name
367sub name_from {
368 my ($self, $file) = @_;
369 if (
370 Module::Install::_read($file) =~ m/
371 ^ \s*
372 package \s*
373 ([\w:]+)
374 \s* ;
375 /ixms
376 ) {
377 my ($name, $module_name) = ($1, $1);
378 $name =~ s{::}{-}g;
379 $self->name($name);
380 unless ( $self->module_name ) {
381 $self->module_name($module_name);
382 }
383 } else {
384 die("Cannot determine name from $file\n");
385 }
386}
387
388sub perl_version_from {
389 my $self = shift;
390 if (
391 Module::Install::_read($_[0]) =~ m/
392 ^
393 (?:use|require) \s*
394 v?
395 ([\d_\.]+)
396 \s* ;
397 /ixms
398 ) {
399 my $perl_version = $1;
400 $perl_version =~ s{_}{}g;
401 $self->perl_version($perl_version);
402 } else {
403 warn "Cannot determine perl version info from $_[0]\n";
404 return;
405 }
406}
407
408sub author_from {
409 my $self = shift;
410 my $content = Module::Install::_read($_[0]);
411 if ($content =~ m/
412 =head \d \s+ (?:authors?)\b \s*
413 ([^\n]*)
414 |
415 =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
416 .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
417 ([^\n]*)
418 /ixms) {
419 my $author = $1 || $2;
420 $author =~ s{E<lt>}{<}g;
421 $author =~ s{E<gt>}{>}g;
422 $self->author($author);
423 } else {
424 warn "Cannot determine author info from $_[0]\n";
425 }
426}
427
428sub license_from {
429 my $self = shift;
430 if (
431 Module::Install::_read($_[0]) =~ m/
432 (
433 =head \d \s+
434 (?:licen[cs]e|licensing|copyright|legal)\b
435 .*?
436 )
437 (=head\\d.*|=cut.*|)
438 \z
439 /ixms ) {
440 my $license_text = $1;
441 my @phrases = (
442 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
443 'GNU general public license' => 'gpl', 1,
444 'GNU public license' => 'gpl', 1,
445 'GNU lesser general public license' => 'lgpl', 1,
446 'GNU lesser public license' => 'lgpl', 1,
447 'GNU library general public license' => 'lgpl', 1,
448 'GNU library public license' => 'lgpl', 1,
449 'BSD license' => 'bsd', 1,
450 'Artistic license' => 'artistic', 1,
451 'GPL' => 'gpl', 1,
452 'LGPL' => 'lgpl', 1,
453 'BSD' => 'bsd', 1,
454 'Artistic' => 'artistic', 1,
455 'MIT' => 'mit', 1,
456 'proprietary' => 'proprietary', 0,
457 );
458 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
459 $pattern =~ s{\s+}{\\s+}g;
460 if ( $license_text =~ /\b$pattern\b/i ) {
461 $self->license($license);
462 return 1;
463 }
464 }
465 }
466
467 warn "Cannot determine license info from $_[0]\n";
468 return 'unknown';
469}
470
471sub _extract_bugtracker {
472 my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
473 my %links;
474 @links{@links}=();
475 @links=keys %links;
476 return @links;
477}
478
479sub bugtracker_from {
480 my $self = shift;
481 my $content = Module::Install::_read($_[0]);
482 my @links = _extract_bugtracker($content);
483 unless ( @links ) {
484 warn "Cannot determine bugtracker info from $_[0]\n";
485 return 0;
486 }
487 if ( @links > 1 ) {
488 warn "Found more than on rt.cpan.org link in $_[0]\n";
489 return 0;
490 }
491
492 # Set the bugtracker
493 bugtracker( $links[0] );
494 return 1;
495}
496
497sub requires_from {
498 my $self = shift;
499 my $content = Module::Install::_readperl($_[0]);
500 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
501 while ( @requires ) {
502 my $module = shift @requires;
503 my $version = shift @requires;
504 $self->requires( $module => $version );
505 }
506}
507
508sub test_requires_from {
509 my $self = shift;
510 my $content = Module::Install::_readperl($_[0]);
511 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
512 while ( @requires ) {
513 my $module = shift @requires;
514 my $version = shift @requires;
515 $self->test_requires( $module => $version );
516 }
517}
518
519# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
520# numbers (eg, 5.006001 or 5.008009).
521# Also, convert double-part versions (eg, 5.8)
522sub _perl_version {
523 my $v = $_[-1];
524 $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
525 $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
526 $v =~ s/(\.\d\d\d)000$/$1/;
527 $v =~ s/_.+$//;
528 if ( ref($v) ) {
529 # Numify
530 $v = $v + 0;
531 }
532 return $v;
533}
534
535
536
537
538
539######################################################################
540# MYMETA Support
541
542sub WriteMyMeta {
543 die "WriteMyMeta has been deprecated";
544}
545
546sub write_mymeta_yaml {
547 my $self = shift;
548
549 # We need YAML::Tiny to write the MYMETA.yml file
550 unless ( eval { require YAML::Tiny; 1; } ) {
551 return 1;
552 }
553
554 # Generate the data
555 my $meta = $self->_write_mymeta_data or return 1;
556
557 # Save as the MYMETA.yml file
558 print "Writing MYMETA.yml\n";
559 YAML::Tiny::DumpFile('MYMETA.yml', $meta);
560}
561
562sub write_mymeta_json {
563 my $self = shift;
564
565 # We need JSON to write the MYMETA.json file
566 unless ( eval { require JSON; 1; } ) {
567 return 1;
568 }
569
570 # Generate the data
571 my $meta = $self->_write_mymeta_data or return 1;
572
573 # Save as the MYMETA.yml file
574 print "Writing MYMETA.json\n";
575 Module::Install::_write(
576 'MYMETA.json',
577 JSON->new->pretty(1)->canonical->encode($meta),
578 );
579}
580
581sub _write_mymeta_data {
582 my $self = shift;
583
584 # If there's no existing META.yml there is nothing we can do
585 return undef unless -f 'META.yml';
586
587 # We need Parse::CPAN::Meta to load the file
588 unless ( eval { require Parse::CPAN::Meta; 1; } ) {
589 return undef;
590 }
591
592 # Merge the perl version into the dependencies
593 my $val = $self->Meta->{values};
594 my $perl = delete $val->{perl_version};
595 if ( $perl ) {
596 $val->{requires} ||= [];
597 my $requires = $val->{requires};
598
599 # Canonize to three-dot version after Perl 5.6
600 if ( $perl >= 5.006 ) {
601 $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
602 }
603 unshift @$requires, [ perl => $perl ];
604 }
605
606 # Load the advisory META.yml file
607 my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
608 my $meta = $yaml[0];
609
610 # Overwrite the non-configure dependency hashs
611 delete $meta->{requires};
612 delete $meta->{build_requires};
613 delete $meta->{recommends};
614 if ( exists $val->{requires} ) {
615 $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
616 }
617 if ( exists $val->{build_requires} ) {
618 $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
619 }
620
621 return $meta;
622}
623
6241;