source: perl/modules/IRC/inc/Module/Install/Metadata.pm @ 50dd3a0

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 50dd3a0 was 43c62e4, checked in by Nelson Elhage <nelhage@mit.edu>, 13 years ago
Commit inc/ under IRC so we build on systems with too old a M::I
  • Property mode set to 100644
File size: 8.8 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.68';
10        $ISCORE  = 1;
11        @ISA     = qw{Module::Install::Base};
12}
13
14my @scalar_keys = qw{
15    name module_name abstract author version license
16    distribution_type perl_version tests installdirs
17};
18
19my @tuple_keys = qw{
20    build_requires requires recommends bundles
21};
22
23sub Meta            { shift        }
24sub Meta_ScalarKeys { @scalar_keys }
25sub Meta_TupleKeys  { @tuple_keys  }
26
27foreach my $key (@scalar_keys) {
28    *$key = sub {
29        my $self = shift;
30        return $self->{values}{$key} if defined wantarray and !@_;
31        $self->{values}{$key} = shift;
32        return $self;
33    };
34}
35
36foreach my $key (@tuple_keys) {
37    *$key = sub {
38        my $self = shift;
39        return $self->{values}{$key} unless @_;
40
41        my @rv;
42        while (@_) {
43            my $module = shift or last;
44            my $version = shift || 0;
45            if ( $module eq 'perl' ) {
46                $version =~ s{^(\d+)\.(\d+)\.(\d+)}
47                             {$1 + $2/1_000 + $3/1_000_000}e;
48                $self->perl_version($version);
49                next;
50            }
51            my $rv = [ $module, $version ];
52            push @rv, $rv;
53        }
54        push @{ $self->{values}{$key} }, @rv;
55        @rv;
56    };
57}
58
59# configure_requires is currently a null-op
60sub configure_requires { 1 }
61
62# Aliases for build_requires that will have alternative
63# meanings in some future version of META.yml.
64sub test_requires      { shift->build_requires(@_)  }
65sub install_requires   { shift->build_requires(@_)  }
66
67# Aliases for installdirs options
68sub install_as_core    { $_[0]->installdirs('perl')   }
69sub install_as_cpan    { $_[0]->installdirs('site')   }
70sub install_as_site    { $_[0]->installdirs('site')   }
71sub install_as_vendor  { $_[0]->installdirs('vendor') }
72
73sub sign {
74    my $self = shift;
75    return $self->{'values'}{'sign'} if defined wantarray and ! @_;
76    $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
77    return $self;
78}
79
80sub dynamic_config {
81        my $self = shift;
82        unless ( @_ ) {
83                warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
84                return $self;
85        }
86        $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
87        return $self;
88}
89
90sub all_from {
91    my ( $self, $file ) = @_;
92
93    unless ( defined($file) ) {
94        my $name = $self->name
95            or die "all_from called with no args without setting name() first";
96        $file = join('/', 'lib', split(/-/, $name)) . '.pm';
97        $file =~ s{.*/}{} unless -e $file;
98        die "all_from: cannot find $file from $name" unless -e $file;
99    }
100
101    $self->version_from($file)      unless $self->version;
102    $self->perl_version_from($file) unless $self->perl_version;
103
104    # The remaining probes read from POD sections; if the file
105    # has an accompanying .pod, use that instead
106    my $pod = $file;
107    if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
108        $file = $pod;
109    }
110
111    $self->author_from($file)   unless $self->author;
112    $self->license_from($file)  unless $self->license;
113    $self->abstract_from($file) unless $self->abstract;
114}
115
116sub provides {
117    my $self     = shift;
118    my $provides = ( $self->{values}{provides} ||= {} );
119    %$provides = (%$provides, @_) if @_;
120    return $provides;
121}
122
123sub auto_provides {
124    my $self = shift;
125    return $self unless $self->is_admin;
126
127    unless (-e 'MANIFEST') {
128        warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
129        return $self;
130    }
131
132    # Avoid spurious warnings as we are not checking manifest here.
133
134    local $SIG{__WARN__} = sub {1};
135    require ExtUtils::Manifest;
136    local *ExtUtils::Manifest::manicheck = sub { return };
137
138    require Module::Build;
139    my $build = Module::Build->new(
140        dist_name    => $self->name,
141        dist_version => $self->version,
142        license      => $self->license,
143    );
144    $self->provides(%{ $build->find_dist_packages || {} });
145}
146
147sub feature {
148    my $self     = shift;
149    my $name     = shift;
150    my $features = ( $self->{values}{features} ||= [] );
151
152    my $mods;
153
154    if ( @_ == 1 and ref( $_[0] ) ) {
155        # The user used ->feature like ->features by passing in the second
156        # argument as a reference.  Accomodate for that.
157        $mods = $_[0];
158    } else {
159        $mods = \@_;
160    }
161
162    my $count = 0;
163    push @$features, (
164        $name => [
165            map {
166                ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
167                                                : @$_
168                        : $_
169            } @$mods
170        ]
171    );
172
173    return @$features;
174}
175
176sub features {
177    my $self = shift;
178    while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
179        $self->feature( $name, @$mods );
180    }
181    return $self->{values}->{features}
182        ? @{ $self->{values}->{features} }
183        : ();
184}
185
186sub no_index {
187    my $self = shift;
188    my $type = shift;
189    push @{ $self->{values}{no_index}{$type} }, @_ if $type;
190    return $self->{values}{no_index};
191}
192
193sub read {
194    my $self = shift;
195    $self->include_deps( 'YAML', 0 );
196
197    require YAML;
198    my $data = YAML::LoadFile('META.yml');
199
200    # Call methods explicitly in case user has already set some values.
201    while ( my ( $key, $value ) = each %$data ) {
202        next unless $self->can($key);
203        if ( ref $value eq 'HASH' ) {
204            while ( my ( $module, $version ) = each %$value ) {
205                $self->can($key)->($self, $module => $version );
206            }
207        }
208        else {
209            $self->can($key)->($self, $value);
210        }
211    }
212    return $self;
213}
214
215sub write {
216    my $self = shift;
217    return $self unless $self->is_admin;
218    $self->admin->write_meta;
219    return $self;
220}
221
222sub version_from {
223    my ( $self, $file ) = @_;
224    require ExtUtils::MM_Unix;
225    $self->version( ExtUtils::MM_Unix->parse_version($file) );
226}
227
228sub abstract_from {
229    my ( $self, $file ) = @_;
230    require ExtUtils::MM_Unix;
231    $self->abstract(
232        bless(
233            { DISTNAME => $self->name },
234            'ExtUtils::MM_Unix'
235        )->parse_abstract($file)
236     );
237}
238
239sub _slurp {
240    my ( $self, $file ) = @_;
241
242    local *FH;
243    open FH, "< $file" or die "Cannot open $file.pod: $!";
244    do { local $/; <FH> };
245}
246
247sub perl_version_from {
248    my ( $self, $file ) = @_;
249
250    if (
251        $self->_slurp($file) =~ m/
252        ^
253        use \s*
254        v?
255        ([\d_\.]+)
256        \s* ;
257    /ixms
258      )
259    {
260        my $v = $1;
261        $v =~ s{_}{}g;
262        $self->perl_version($1);
263    }
264    else {
265        warn "Cannot determine perl version info from $file\n";
266        return;
267    }
268}
269
270sub author_from {
271    my ( $self, $file ) = @_;
272    my $content = $self->_slurp($file);
273    if ($content =~ m/
274        =head \d \s+ (?:authors?)\b \s*
275        ([^\n]*)
276        |
277        =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
278        .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
279        ([^\n]*)
280    /ixms) {
281        my $author = $1 || $2;
282        $author =~ s{E<lt>}{<}g;
283        $author =~ s{E<gt>}{>}g;
284        $self->author($author); 
285    }
286    else {
287        warn "Cannot determine author info from $file\n";
288    }
289}
290
291sub license_from {
292    my ( $self, $file ) = @_;
293
294    if (
295        $self->_slurp($file) =~ m/
296        (
297            =head \d \s+
298            (?:licen[cs]e|licensing|copyright|legal)\b
299            .*?
300        )
301        (=head\\d.*|=cut.*|)
302        \z
303    /ixms
304      )
305    {
306        my $license_text = $1;
307        my @phrases      = (
308            'under the same (?:terms|license) as perl itself' => 'perl',        1,
309            'GNU public license'                              => 'gpl',         1,
310            'GNU lesser public license'                       => 'gpl',         1,
311            'BSD license'                                     => 'bsd',         1,
312            'Artistic license'                                => 'artistic',    1,
313            'GPL'                                             => 'gpl',         1,
314            'LGPL'                                            => 'lgpl',        1,
315            'BSD'                                             => 'bsd',         1,
316            'Artistic'                                        => 'artistic',    1,
317            'MIT'                                             => 'mit',         1,
318            'proprietary'                                     => 'proprietary', 0,
319        );
320        while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
321            $pattern =~ s{\s+}{\\s+}g;
322            if ( $license_text =~ /\b$pattern\b/i ) {
323                if ( $osi and $license_text =~ /All rights reserved/i ) {
324                        warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
325                }
326                $self->license($license);
327                return 1;
328            }
329        }
330    }
331
332    warn "Cannot determine license info from $file\n";
333    return 'unknown';
334}
335
3361;
Note: See TracBrowser for help on using the repository browser.