← Back to branch summary

~ubuntu-branches/ubuntu/maverick/libclass-accessor-grouped-perl/maverick

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): gregor herrmann
  • Date: 2007-07-14 21:51:56 UTC
  • Revision ID: james.westby@ubuntu.com-20070714215156-l0iazyikbi21rpu8
Tags: upstream-0.07000
Import upstream version 0.07000

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 $ISCORE @ISA};
 
8
BEGIN {
 
9
        $VERSION = '0.67';
 
10
        $ISCORE  = 1;
 
11
        @ISA     = qw{Module::Install::Base};
 
12
}
 
13
 
 
14
my @scalar_keys = qw{
 
15
    name module_name abstract author version license
 
16
    distribution_type perl_version tests installdirs
 
17
};
 
18
 
 
19
my @tuple_keys = qw{
 
20
    build_requires requires recommends bundles
 
21
};
 
22
 
 
23
sub Meta            { shift        }
 
24
sub Meta_ScalarKeys { @scalar_keys }
 
25
sub Meta_TupleKeys  { @tuple_keys  }
 
26
 
 
27
foreach 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
 
 
36
foreach 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
 
60
sub configure_requires { 1 }
 
61
 
 
62
# Aliases for build_requires that will have alternative
 
63
# meanings in some future version of META.yml.
 
64
sub test_requires      { shift->build_requires(@_)  }
 
65
sub install_requires   { shift->build_requires(@_)  }
 
66
 
 
67
# Aliases for installdirs options
 
68
sub install_as_core    { $_[0]->installdirs('perl')   }
 
69
sub install_as_cpan    { $_[0]->installdirs('site')   }
 
70
sub install_as_site    { $_[0]->installdirs('site')   }
 
71
sub install_as_vendor  { $_[0]->installdirs('vendor') }
 
72
 
 
73
sub 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
 
 
80
sub 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
 
 
90
sub 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
 
 
116
sub provides {
 
117
    my $self     = shift;
 
118
    my $provides = ( $self->{values}{provides} ||= {} );
 
119
    %$provides = (%$provides, @_) if @_;
 
120
    return $provides;
 
121
}
 
122
 
 
123
sub 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
 
 
147
sub 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
 
 
176
sub 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
 
 
186
sub 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
 
 
193
sub 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
 
 
215
sub write {
 
216
    my $self = shift;
 
217
    return $self unless $self->is_admin;
 
218
    $self->admin->write_meta;
 
219
    return $self;
 
220
}
 
221
 
 
222
sub version_from {
 
223
    my ( $self, $file ) = @_;
 
224
    require ExtUtils::MM_Unix;
 
225
    $self->version( ExtUtils::MM_Unix->parse_version($file) );
 
226
}
 
227
 
 
228
sub 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
 
 
239
sub _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
 
 
247
sub 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
 
 
270
sub 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
 
 
291
sub 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
 
 
336
1;