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