← Back to branch summary

~ubuntu-branches/ubuntu/natty/libsignatures-perl/natty

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-05-18 20:34:44 UTC
  • Revision ID: james.westby@ubuntu.com-20090518203444-ee3iqibpk6uxo7u8
Tags: upstream-0.05
Import upstream version 0.05

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