source: perl/modules/WordWrap/inc/Module/Install/Metadata.pm @ 1375a6a

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