← Back to branch summary

~ubuntu-branches/ubuntu/trusty/libnamespace-clean-perl/trusty

« back to all changes in this revision

Viewing changes to inc/Module/Install/Metadata.pm

  • Committer: Bazaar Package Importer
  • Author(s): gregor herrmann, Ansgar Burchardt, gregor herrmann
  • Date: 2010-06-13 14:20:13 UTC
  • mfrom: (1.1.6 upstream)
  • Revision ID: james.westby@ubuntu.com-20100613142013-5pl6g9bsrbqu57oj
Tags: 0.17-1
[ Ansgar Burchardt ]
* New upstream release.
* debian/copyright: Remove information on inc/* (removed upstream).
* Add (build-)dep on libpackage-stash-perl.
* Add myself to Uploaders.

[ gregor herrmann ]
* Refresh fix-pod-spelling.patch.
* debian/copyright: update upstream copyright year.

Show diffs side-by-side

added added

removed removed

Lines of Context:
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 = '0.95';
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
 
        unless ( @_ ) {
156
 
                warn "You MUST provide an explicit true/false value to dynamic_config\n";
157
 
                return $self;
158
 
        }
159
 
        $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
160
 
        return 1;
161
 
}
162
 
 
163
 
sub perl_version {
164
 
        my $self = shift;
165
 
        return $self->{values}->{perl_version} unless @_;
166
 
        my $version = shift or die(
167
 
                "Did not provide a value to perl_version()"
168
 
        );
169
 
 
170
 
        # Normalize the version
171
 
        $version = $self->_perl_version($version);
172
 
 
173
 
        # We don't support the reall old versions
174
 
        unless ( $version >= 5.005 ) {
175
 
                die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
176
 
        }
177
 
 
178
 
        $self->{values}->{perl_version} = $version;
179
 
}
180
 
 
181
 
#Stolen from M::B
182
 
my %license_urls = (
183
 
    perl         => 'http://dev.perl.org/licenses/',
184
 
    apache       => 'http://apache.org/licenses/LICENSE-2.0',
185
 
    artistic     => 'http://opensource.org/licenses/artistic-license.php',
186
 
    artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
187
 
    lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
188
 
    lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
189
 
    lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
190
 
    bsd          => 'http://opensource.org/licenses/bsd-license.php',
191
 
    gpl          => 'http://opensource.org/licenses/gpl-license.php',
192
 
    gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
193
 
    gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
194
 
    mit          => 'http://opensource.org/licenses/mit-license.php',
195
 
    mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
196
 
    open_source  => undef,
197
 
    unrestricted => undef,
198
 
    restrictive  => undef,
199
 
    unknown      => undef,
200
 
);
201
 
 
202
 
sub license {
203
 
        my $self = shift;
204
 
        return $self->{values}->{license} unless @_;
205
 
        my $license = shift or die(
206
 
                'Did not provide a value to license()'
207
 
        );
208
 
        $self->{values}->{license} = $license;
209
 
 
210
 
        # Automatically fill in license URLs
211
 
        if ( $license_urls{$license} ) {
212
 
                $self->resources( license => $license_urls{$license} );
213
 
        }
214
 
 
215
 
        return 1;
216
 
}
217
 
 
218
 
sub all_from {
219
 
        my ( $self, $file ) = @_;
220
 
 
221
 
        unless ( defined($file) ) {
222
 
                my $name = $self->name or die(
223
 
                        "all_from called with no args without setting name() first"
224
 
                );
225
 
                $file = join('/', 'lib', split(/-/, $name)) . '.pm';
226
 
                $file =~ s{.*/}{} unless -e $file;
227
 
                unless ( -e $file ) {
228
 
                        die("all_from cannot find $file from $name");
229
 
                }
230
 
        }
231
 
        unless ( -f $file ) {
232
 
                die("The path '$file' does not exist, or is not a file");
233
 
        }
234
 
 
235
 
        $self->{values}{all_from} = $file;
236
 
 
237
 
        # Some methods pull from POD instead of code.
238
 
        # If there is a matching .pod, use that instead
239
 
        my $pod = $file;
240
 
        $pod =~ s/\.pm$/.pod/i;
241
 
        $pod = $file unless -e $pod;
242
 
 
243
 
        # Pull the different values
244
 
        $self->name_from($file)         unless $self->name;
245
 
        $self->version_from($file)      unless $self->version;
246
 
        $self->perl_version_from($file) unless $self->perl_version;
247
 
        $self->author_from($pod)        unless @{$self->author || []};
248
 
        $self->license_from($pod)       unless $self->license;
249
 
        $self->abstract_from($pod)      unless $self->abstract;
250
 
 
251
 
        return 1;
252
 
}
253
 
 
254
 
sub provides {
255
 
        my $self     = shift;
256
 
        my $provides = ( $self->{values}->{provides} ||= {} );
257
 
        %$provides = (%$provides, @_) if @_;
258
 
        return $provides;
259
 
}
260
 
 
261
 
sub auto_provides {
262
 
        my $self = shift;
263
 
        return $self unless $self->is_admin;
264
 
        unless (-e 'MANIFEST') {
265
 
                warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
266
 
                return $self;
267
 
        }
268
 
        # Avoid spurious warnings as we are not checking manifest here.
269
 
        local $SIG{__WARN__} = sub {1};
270
 
        require ExtUtils::Manifest;
271
 
        local *ExtUtils::Manifest::manicheck = sub { return };
272
 
 
273
 
        require Module::Build;
274
 
        my $build = Module::Build->new(
275
 
                dist_name    => $self->name,
276
 
                dist_version => $self->version,
277
 
                license      => $self->license,
278
 
        );
279
 
        $self->provides( %{ $build->find_dist_packages || {} } );
280
 
}
281
 
 
282
 
sub feature {
283
 
        my $self     = shift;
284
 
        my $name     = shift;
285
 
        my $features = ( $self->{values}->{features} ||= [] );
286
 
        my $mods;
287
 
 
288
 
        if ( @_ == 1 and ref( $_[0] ) ) {
289
 
                # The user used ->feature like ->features by passing in the second
290
 
                # argument as a reference.  Accomodate for that.
291
 
                $mods = $_[0];
292
 
        } else {
293
 
                $mods = \@_;
294
 
        }
295
 
 
296
 
        my $count = 0;
297
 
        push @$features, (
298
 
                $name => [
299
 
                        map {
300
 
                                ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
301
 
                        } @$mods
302
 
                ]
303
 
        );
304
 
 
305
 
        return @$features;
306
 
}
307
 
 
308
 
sub features {
309
 
        my $self = shift;
310
 
        while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
311
 
                $self->feature( $name, @$mods );
312
 
        }
313
 
        return $self->{values}->{features}
314
 
                ? @{ $self->{values}->{features} }
315
 
                : ();
316
 
}
317
 
 
318
 
sub no_index {
319
 
        my $self = shift;
320
 
        my $type = shift;
321
 
        push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
322
 
        return $self->{values}->{no_index};
323
 
}
324
 
 
325
 
sub read {
326
 
        my $self = shift;
327
 
        $self->include_deps( 'YAML::Tiny', 0 );
328
 
 
329
 
        require YAML::Tiny;
330
 
        my $data = YAML::Tiny::LoadFile('META.yml');
331
 
 
332
 
        # Call methods explicitly in case user has already set some values.
333
 
        while ( my ( $key, $value ) = each %$data ) {
334
 
                next unless $self->can($key);
335
 
                if ( ref $value eq 'HASH' ) {
336
 
                        while ( my ( $module, $version ) = each %$value ) {
337
 
                                $self->can($key)->($self, $module => $version );
338
 
                        }
339
 
                } else {
340
 
                        $self->can($key)->($self, $value);
341
 
                }
342
 
        }
343
 
        return $self;
344
 
}
345
 
 
346
 
sub write {
347
 
        my $self = shift;
348
 
        return $self unless $self->is_admin;
349
 
        $self->admin->write_meta;
350
 
        return $self;
351
 
}
352
 
 
353
 
sub version_from {
354
 
        require ExtUtils::MM_Unix;
355
 
        my ( $self, $file ) = @_;
356
 
        $self->version( ExtUtils::MM_Unix->parse_version($file) );
357
 
}
358
 
 
359
 
sub abstract_from {
360
 
        require ExtUtils::MM_Unix;
361
 
        my ( $self, $file ) = @_;
362
 
        $self->abstract(
363
 
                bless(
364
 
                        { DISTNAME => $self->name },
365
 
                        'ExtUtils::MM_Unix'
366
 
                )->parse_abstract($file)
367
 
         );
368
 
}
369
 
 
370
 
# Add both distribution and module name
371
 
sub name_from {
372
 
        my ($self, $file) = @_;
373
 
        if (
374
 
                Module::Install::_read($file) =~ m/
375
 
                ^ \s*
376
 
                package \s*
377
 
                ([\w:]+)
378
 
                \s* ;
379
 
                /ixms
380
 
        ) {
381
 
                my ($name, $module_name) = ($1, $1);
382
 
                $name =~ s{::}{-}g;
383
 
                $self->name($name);
384
 
                unless ( $self->module_name ) {
385
 
                        $self->module_name($module_name);
386
 
                }
387
 
        } else {
388
 
                die("Cannot determine name from $file\n");
389
 
        }
390
 
}
391
 
 
392
 
sub _extract_perl_version {
393
 
        if (
394
 
                $_[0] =~ m/
395
 
                ^\s*
396
 
                (?:use|require) \s*
397
 
                v?
398
 
                ([\d_\.]+)
399
 
                \s* ;
400
 
                /ixms
401
 
        ) {
402
 
                my $perl_version = $1;
403
 
                $perl_version =~ s{_}{}g;
404
 
                return $perl_version;
405
 
        } else {
406
 
                return;
407
 
        }
408
 
}
409
 
 
410
 
sub perl_version_from {
411
 
        my $self = shift;
412
 
        my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
413
 
        if ($perl_version) {
414
 
                $self->perl_version($perl_version);
415
 
        } else {
416
 
                warn "Cannot determine perl version info from $_[0]\n";
417
 
                return;
418
 
        }
419
 
}
420
 
 
421
 
sub author_from {
422
 
        my $self    = shift;
423
 
        my $content = Module::Install::_read($_[0]);
424
 
        if ($content =~ m/
425
 
                =head \d \s+ (?:authors?)\b \s*
426
 
                ([^\n]*)
427
 
                |
428
 
                =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
429
 
                .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
430
 
                ([^\n]*)
431
 
        /ixms) {
432
 
                my $author = $1 || $2;
433
 
 
434
 
                # XXX: ugly but should work anyway...
435
 
                if (eval "require Pod::Escapes; 1") {
436
 
                        # Pod::Escapes has a mapping table.
437
 
                        # It's in core of perl >= 5.9.3, and should be installed
438
 
                        # as one of the Pod::Simple's prereqs, which is a prereq
439
 
                        # of Pod::Text 3.x (see also below).
440
 
                        $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
441
 
                        {
442
 
                                defined $2
443
 
                                ? chr($2)
444
 
                                : defined $Pod::Escapes::Name2character_number{$1}
445
 
                                ? chr($Pod::Escapes::Name2character_number{$1})
446
 
                                : do {
447
 
                                        warn "Unknown escape: E<$1>";
448
 
                                        "E<$1>";
449
 
                                };
450
 
                        }gex;
451
 
                }
452
 
                elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
453
 
                        # Pod::Text < 3.0 has yet another mapping table,
454
 
                        # though the table name of 2.x and 1.x are different.
455
 
                        # (1.x is in core of Perl < 5.6, 2.x is in core of
456
 
                        # Perl < 5.9.3)
457
 
                        my $mapping = ($Pod::Text::VERSION < 2)
458
 
                                ? \%Pod::Text::HTML_Escapes
459
 
                                : \%Pod::Text::ESCAPES;
460
 
                        $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
461
 
                        {
462
 
                                defined $2
463
 
                                ? chr($2)
464
 
                                : defined $mapping->{$1}
465
 
                                ? $mapping->{$1}
466
 
                                : do {
467
 
                                        warn "Unknown escape: E<$1>";
468
 
                                        "E<$1>";
469
 
                                };
470
 
                        }gex;
471
 
                }
472
 
                else {
473
 
                        $author =~ s{E<lt>}{<}g;
474
 
                        $author =~ s{E<gt>}{>}g;
475
 
                }
476
 
                $self->author($author);
477
 
        } else {
478
 
                warn "Cannot determine author info from $_[0]\n";
479
 
        }
480
 
}
481
 
 
482
 
sub _extract_license {
483
 
        my $pod = shift;
484
 
        my $matched;
485
 
        return __extract_license(
486
 
                ($matched) = $pod =~ m/
487
 
                        (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
488
 
                        (=head \d.*|=cut.*|)\z
489
 
                /ixms
490
 
        ) || __extract_license(
491
 
                ($matched) = $pod =~ m/
492
 
                        (=head \d \s+ (?:copyrights?|legal)\b.*?)
493
 
                        (=head \d.*|=cut.*|)\z
494
 
                /ixms
495
 
        );
496
 
}
497
 
 
498
 
sub __extract_license {
499
 
        my $license_text = shift or return;
500
 
        my @phrases      = (
501
 
                'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
502
 
                'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
503
 
                'Artistic and GPL'                   => 'perl',        1,
504
 
                'GNU general public license'         => 'gpl',         1,
505
 
                'GNU public license'                 => 'gpl',         1,
506
 
                'GNU lesser general public license'  => 'lgpl',        1,
507
 
                'GNU lesser public license'          => 'lgpl',        1,
508
 
                'GNU library general public license' => 'lgpl',        1,
509
 
                'GNU library public license'         => 'lgpl',        1,
510
 
                'BSD license'                        => 'bsd',         1,
511
 
                'Artistic license'                   => 'artistic',    1,
512
 
                'GPL'                                => 'gpl',         1,
513
 
                'LGPL'                               => 'lgpl',        1,
514
 
                'BSD'                                => 'bsd',         1,
515
 
                'Artistic'                           => 'artistic',    1,
516
 
                'MIT'                                => 'mit',         1,
517
 
                'proprietary'                        => 'proprietary', 0,
518
 
        );
519
 
        while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
520
 
                $pattern =~ s#\s+#\\s+#gs;
521
 
                if ( $license_text =~ /\b$pattern\b/i ) {
522
 
                        return $license;
523
 
                }
524
 
        }
525
 
}
526
 
 
527
 
sub license_from {
528
 
        my $self = shift;
529
 
        if (my $license=_extract_license(Module::Install::_read($_[0]))) {
530
 
                $self->license($license);
531
 
        } else {
532
 
                warn "Cannot determine license info from $_[0]\n";
533
 
                return 'unknown';
534
 
        }
535
 
}
536
 
 
537
 
sub _extract_bugtracker {
538
 
        my @links   = $_[0] =~ m#L<(
539
 
         \Qhttp://rt.cpan.org/\E[^>]+|
540
 
         \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
541
 
         \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
542
 
         )>#gx;
543
 
        my %links;
544
 
        @links{@links}=();
545
 
        @links=keys %links;
546
 
        return @links;
547
 
}
548
 
 
549
 
sub bugtracker_from {
550
 
        my $self    = shift;
551
 
        my $content = Module::Install::_read($_[0]);
552
 
        my @links   = _extract_bugtracker($content);
553
 
        unless ( @links ) {
554
 
                warn "Cannot determine bugtracker info from $_[0]\n";
555
 
                return 0;
556
 
        }
557
 
        if ( @links > 1 ) {
558
 
                warn "Found more than one bugtracker link in $_[0]\n";
559
 
                return 0;
560
 
        }
561
 
 
562
 
        # Set the bugtracker
563
 
        bugtracker( $links[0] );
564
 
        return 1;
565
 
}
566
 
 
567
 
sub requires_from {
568
 
        my $self     = shift;
569
 
        my $content  = Module::Install::_readperl($_[0]);
570
 
        my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
571
 
        while ( @requires ) {
572
 
                my $module  = shift @requires;
573
 
                my $version = shift @requires;
574
 
                $self->requires( $module => $version );
575
 
        }
576
 
}
577
 
 
578
 
sub test_requires_from {
579
 
        my $self     = shift;
580
 
        my $content  = Module::Install::_readperl($_[0]);
581
 
        my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
582
 
        while ( @requires ) {
583
 
                my $module  = shift @requires;
584
 
                my $version = shift @requires;
585
 
                $self->test_requires( $module => $version );
586
 
        }
587
 
}
588
 
 
589
 
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
590
 
# numbers (eg, 5.006001 or 5.008009).
591
 
# Also, convert double-part versions (eg, 5.8)
592
 
sub _perl_version {
593
 
        my $v = $_[-1];
594
 
        $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
595
 
        $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
596
 
        $v =~ s/(\.\d\d\d)000$/$1/;
597
 
        $v =~ s/_.+$//;
598
 
        if ( ref($v) ) {
599
 
                # Numify
600
 
                $v = $v + 0;
601
 
        }
602
 
        return $v;
603
 
}
604
 
 
605
 
 
606
 
 
607
 
 
608
 
 
609
 
######################################################################
610
 
# MYMETA Support
611
 
 
612
 
sub WriteMyMeta {
613
 
        die "WriteMyMeta has been deprecated";
614
 
}
615
 
 
616
 
sub write_mymeta_yaml {
617
 
        my $self = shift;
618
 
 
619
 
        # We need YAML::Tiny to write the MYMETA.yml file
620
 
        unless ( eval { require YAML::Tiny; 1; } ) {
621
 
                return 1;
622
 
        }
623
 
 
624
 
        # Generate the data
625
 
        my $meta = $self->_write_mymeta_data or return 1;
626
 
 
627
 
        # Save as the MYMETA.yml file
628
 
        print "Writing MYMETA.yml\n";
629
 
        YAML::Tiny::DumpFile('MYMETA.yml', $meta);
630
 
}
631
 
 
632
 
sub write_mymeta_json {
633
 
        my $self = shift;
634
 
 
635
 
        # We need JSON to write the MYMETA.json file
636
 
        unless ( eval { require JSON; 1; } ) {
637
 
                return 1;
638
 
        }
639
 
 
640
 
        # Generate the data
641
 
        my $meta = $self->_write_mymeta_data or return 1;
642
 
 
643
 
        # Save as the MYMETA.yml file
644
 
        print "Writing MYMETA.json\n";
645
 
        Module::Install::_write(
646
 
                'MYMETA.json',
647
 
                JSON->new->pretty(1)->canonical->encode($meta),
648
 
        );
649
 
}
650
 
 
651
 
sub _write_mymeta_data {
652
 
        my $self = shift;
653
 
 
654
 
        # If there's no existing META.yml there is nothing we can do
655
 
        return undef unless -f 'META.yml';
656
 
 
657
 
        # We need Parse::CPAN::Meta to load the file
658
 
        unless ( eval { require Parse::CPAN::Meta; 1; } ) {
659
 
                return undef;
660
 
        }
661
 
 
662
 
        # Merge the perl version into the dependencies
663
 
        my $val  = $self->Meta->{values};
664
 
        my $perl = delete $val->{perl_version};
665
 
        if ( $perl ) {
666
 
                $val->{requires} ||= [];
667
 
                my $requires = $val->{requires};
668
 
 
669
 
                # Canonize to three-dot version after Perl 5.6
670
 
                if ( $perl >= 5.006 ) {
671
 
                        $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
672
 
                }
673
 
                unshift @$requires, [ perl => $perl ];
674
 
        }
675
 
 
676
 
        # Load the advisory META.yml file
677
 
        my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
678
 
        my $meta = $yaml[0];
679
 
 
680
 
        # Overwrite the non-configure dependency hashs
681
 
        delete $meta->{requires};
682
 
        delete $meta->{build_requires};
683
 
        delete $meta->{recommends};
684
 
        if ( exists $val->{requires} ) {
685
 
                $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
686
 
        }
687
 
        if ( exists $val->{build_requires} ) {
688
 
                $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
689
 
        }
690
 
 
691
 
        return $meta;
692
 
}
693
 
 
694
 
1;