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.64';
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
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
59sub sign {
60    my $self = shift;
61    return $self->{'values'}{'sign'} if defined wantarray and !@_;
62    $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
63    return $self;
64}
65
66sub dynamic_config {
67	my $self = shift;
68	unless ( @_ ) {
69		warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
70		return $self;
71	}
72	$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
73	return $self;
74}
75
76sub all_from {
77    my ( $self, $file ) = @_;
78
79    unless ( defined($file) ) {
80        my $name = $self->name
81            or die "all_from called with no args without setting name() first";
82        $file = join('/', 'lib', split(/-/, $name)) . '.pm';
83        $file =~ s{.*/}{} unless -e $file;
84        die "all_from: cannot find $file from $name" unless -e $file;
85    }
86
87    $self->version_from($file)      unless $self->version;
88    $self->perl_version_from($file) unless $self->perl_version;
89
90    # The remaining probes read from POD sections; if the file
91    # has an accompanying .pod, use that instead
92    my $pod = $file;
93    if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
94        $file = $pod;
95    }
96
97    $self->author_from($file)   unless $self->author;
98    $self->license_from($file)  unless $self->license;
99    $self->abstract_from($file) unless $self->abstract;
100}
101
102sub provides {
103    my $self     = shift;
104    my $provides = ( $self->{values}{provides} ||= {} );
105    %$provides = (%$provides, @_) if @_;
106    return $provides;
107}
108
109sub auto_provides {
110    my $self = shift;
111    return $self unless $self->is_admin;
112
113    unless (-e 'MANIFEST') {
114        warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
115        return $self;
116    }
117
118    # Avoid spurious warnings as we are not checking manifest here.
119
120    local $SIG{__WARN__} = sub {1};
121    require ExtUtils::Manifest;
122    local *ExtUtils::Manifest::manicheck = sub { return };
123
124    require Module::Build;
125    my $build = Module::Build->new(
126        dist_name    => $self->name,
127        dist_version => $self->version,
128        license      => $self->license,
129    );
130    $self->provides(%{ $build->find_dist_packages || {} });
131}
132
133sub feature {
134    my $self     = shift;
135    my $name     = shift;
136    my $features = ( $self->{values}{features} ||= [] );
137
138    my $mods;
139
140    if ( @_ == 1 and ref( $_[0] ) ) {
141        # The user used ->feature like ->features by passing in the second
142        # argument as a reference.  Accomodate for that.
143        $mods = $_[0];
144    } else {
145        $mods = \@_;
146    }
147
148    my $count = 0;
149    push @$features, (
150        $name => [
151            map {
152                ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
153                                                : @$_
154                        : $_
155            } @$mods
156        ]
157    );
158
159    return @$features;
160}
161
162sub features {
163    my $self = shift;
164    while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
165        $self->feature( $name, @$mods );
166    }
167    return $self->{values}->{features}
168    	? @{ $self->{values}->{features} }
169    	: ();
170}
171
172sub no_index {
173    my $self = shift;
174    my $type = shift;
175    push @{ $self->{values}{no_index}{$type} }, @_ if $type;
176    return $self->{values}{no_index};
177}
178
179sub read {
180    my $self = shift;
181    $self->include_deps( 'YAML', 0 );
182
183    require YAML;
184    my $data = YAML::LoadFile('META.yml');
185
186    # Call methods explicitly in case user has already set some values.
187    while ( my ( $key, $value ) = each %$data ) {
188        next unless $self->can($key);
189        if ( ref $value eq 'HASH' ) {
190            while ( my ( $module, $version ) = each %$value ) {
191                $self->can($key)->($self, $module => $version );
192            }
193        }
194        else {
195            $self->can($key)->($self, $value);
196        }
197    }
198    return $self;
199}
200
201sub write {
202    my $self = shift;
203    return $self unless $self->is_admin;
204    $self->admin->write_meta;
205    return $self;
206}
207
208sub version_from {
209    my ( $self, $file ) = @_;
210    require ExtUtils::MM_Unix;
211    $self->version( ExtUtils::MM_Unix->parse_version($file) );
212}
213
214sub abstract_from {
215    my ( $self, $file ) = @_;
216    require ExtUtils::MM_Unix;
217    $self->abstract(
218        bless(
219            { DISTNAME => $self->name },
220            'ExtUtils::MM_Unix'
221        )->parse_abstract($file)
222     );
223}
224
225sub _slurp {
226    my ( $self, $file ) = @_;
227
228    local *FH;
229    open FH, "< $file" or die "Cannot open $file.pod: $!";
230    do { local $/; <FH> };
231}
232
233sub perl_version_from {
234    my ( $self, $file ) = @_;
235
236    if (
237        $self->_slurp($file) =~ m/
238        ^
239        use \s*
240        v?
241        ([\d_\.]+)
242        \s* ;
243    /ixms
244      )
245    {
246        my $v = $1;
247        $v =~ s{_}{}g;
248        $self->perl_version($1);
249    }
250    else {
251        warn "Cannot determine perl version info from $file\n";
252        return;
253    }
254}
255
256sub author_from {
257    my ( $self, $file ) = @_;
258    my $content = $self->_slurp($file);
259    if ($content =~ m/
260        =head \d \s+ (?:authors?)\b \s*
261        ([^\n]*)
262        |
263        =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
264        .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
265        ([^\n]*)
266    /ixms) {
267        my $author = $1 || $2;
268        $author =~ s{E<lt>}{<}g;
269        $author =~ s{E<gt>}{>}g;
270        $self->author($author);
271    }
272    else {
273        warn "Cannot determine author info from $file\n";
274    }
275}
276
277sub license_from {
278    my ( $self, $file ) = @_;
279
280    if (
281        $self->_slurp($file) =~ m/
282        =head \d \s+
283        (?:licen[cs]e|licensing|copyright|legal)\b
284        (.*?)
285        (=head\\d.*|=cut.*|)
286        \z
287    /ixms
288      )
289    {
290        my $license_text = $1;
291        my @phrases      = (
292            'under the same (?:terms|license) as perl itself' => 'perl',
293            'GNU public license'                              => 'gpl',
294            'GNU lesser public license'                       => 'gpl',
295            'BSD license'                                     => 'bsd',
296            'Artistic license'                                => 'artistic',
297            'GPL'                                             => 'gpl',
298            'LGPL'                                            => 'lgpl',
299            'BSD'                                             => 'bsd',
300            'Artistic'                                        => 'artistic',
301        );
302        while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
303            $pattern =~ s{\s+}{\\s+}g;
304            if ( $license_text =~ /\b$pattern\b/i ) {
305                $self->license($license);
306                return 1;
307            }
308        }
309    }
310
311    warn "Cannot determine license info from $file\n";
312    return 'unknown';
313}
314
3151;
316