"Fossies" - the Fresh Open Source Software Archive 
Member "RT-Extension-Assets-1.05/inc/Module/Install/Metadata.pm" (6 May 2015, 18114 Bytes) of package /linux/misc/RT-Extension-Assets-1.05.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "Metadata.pm" see the
Fossies "Dox" file reference documentation and the last
Fossies "Diffs" side-by-side code changes report:
1.02_vs_1.04.
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.14';
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 hashes
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;