Module/Install/Metadata.pm

#line 1
package Module::Install::Metadata;

use strict 'vars';
use Module::Install::Base;

use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
        $VERSION = '0.64';
        $ISCORE  = 1;
        @ISA     = qw{Module::Install::Base};
}

my @scalar_keys = qw{
    name module_name abstract author version license
    distribution_type perl_version tests
};

my @tuple_keys = qw{
    build_requires requires recommends bundles
};

sub Meta            { shift        }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys  { @tuple_keys  }

foreach my $key (@scalar_keys) {
    *$key = sub {
        my $self = shift;
        return $self->{values}{$key} if defined wantarray and !@_;
        $self->{values}{$key} = shift;
        return $self;
    };
}

foreach my $key (@tuple_keys) {
    *$key = sub {
        my $self = shift;
        return $self->{values}{$key} unless @_;

        my @rv;
        while (@_) {
            my $module = shift or last;
            my $version = shift || 0;
            if ( $module eq 'perl' ) {
                $version =~ s{^(\d+)\.(\d+)\.(\d+)}
                             {$1 + $2/1_000 + $3/1_000_000}e;
                $self->perl_version($version);
                next;
            }
            my $rv = [ $module, $version ];
            push @rv, $rv;
        }
        push @{ $self->{values}{$key} }, @rv;
        @rv;
    };
}

sub sign {
    my $self = shift;
    return $self->{'values'}{'sign'} if defined wantarray and !@_;
    $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
    return $self;
}

sub dynamic_config {
        my $self = shift;
        unless ( @_ ) {
                warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
                return $self;
        }
        $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
        return $self;
}

sub all_from {
    my ( $self, $file ) = @_;

    unless ( defined($file) ) {
        my $name = $self->name
            or die "all_from called with no args without setting name() first";
        $file = join('/', 'lib', split(/-/, $name)) . '.pm';
        $file =~ s{.*/}{} unless -e $file;
        die "all_from: cannot find $file from $name" unless -e $file;
    }

    $self->version_from($file)      unless $self->version;
    $self->perl_version_from($file) unless $self->perl_version;

    # The remaining probes read from POD sections; if the file
    # has an accompanying .pod, use that instead
    my $pod = $file;
    if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
        $file = $pod;
    }

    $self->author_from($file)   unless $self->author;
    $self->license_from($file)  unless $self->license;
    $self->abstract_from($file) unless $self->abstract;
}

sub provides {
    my $self     = shift;
    my $provides = ( $self->{values}{provides} ||= {} );
    %$provides = (%$provides, @_) if @_;
    return $provides;
}

sub auto_provides {
    my $self = shift;
    return $self unless $self->is_admin;

    unless (-e 'MANIFEST') {
        warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
        return $self;
    }

    # Avoid spurious warnings as we are not checking manifest here.

    local $SIG{__WARN__} = sub {1};
    require ExtUtils::Manifest;
    local *ExtUtils::Manifest::manicheck = sub { return };

    require Module::Build;
    my $build = Module::Build->new(
        dist_name    => $self->name,
        dist_version => $self->version,
        license      => $self->license,
    );
    $self->provides(%{ $build->find_dist_packages || {} });
}

sub feature {
    my $self     = shift;
    my $name     = shift;
    my $features = ( $self->{values}{features} ||= [] );

    my $mods;

    if ( @_ == 1 and ref( $_[0] ) ) {
        # The user used ->feature like ->features by passing in the second
        # argument as a reference.  Accomodate for that.
        $mods = $_[0];
    } else {
        $mods = \@_;
    }

    my $count = 0;
    push @$features, (
        $name => [
            map {
                ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
                                                : @$_
                        : $_
            } @$mods
        ]
    );

    return @$features;
}

sub features {
    my $self = shift;
    while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
        $self->feature( $name, @$mods );
    }
    return $self->{values}->{features}
        ? @{ $self->{values}->{features} }
        : ();
}

sub no_index {
    my $self = shift;
    my $type = shift;
    push @{ $self->{values}{no_index}{$type} }, @_ if $type;
    return $self->{values}{no_index};
}

sub read {
    my $self = shift;
    $self->include_deps( 'YAML', 0 );

    require YAML;
    my $data = YAML::LoadFile('META.yml');

    # Call methods explicitly in case user has already set some values.
    while ( my ( $key, $value ) = each %$data ) {
        next unless $self->can($key);
        if ( ref $value eq 'HASH' ) {
            while ( my ( $module, $version ) = each %$value ) {
                $self->can($key)->($self, $module => $version );
            }
        }
        else {
            $self->can($key)->($self, $value);
        }
    }
    return $self;
}

sub write {
    my $self = shift;
    return $self unless $self->is_admin;
    $self->admin->write_meta;
    return $self;
}

sub version_from {
    my ( $self, $file ) = @_;
    require ExtUtils::MM_Unix;
    $self->version( ExtUtils::MM_Unix->parse_version($file) );
}

sub abstract_from {
    my ( $self, $file ) = @_;
    require ExtUtils::MM_Unix;
    $self->abstract(
        bless(
            { DISTNAME => $self->name },
            'ExtUtils::MM_Unix'
        )->parse_abstract($file)
     );
}

sub _slurp {
    my ( $self, $file ) = @_;

    local *FH;
    open FH, "< $file" or die "Cannot open $file.pod: $!";
    do { local $/; <FH> };
}

sub perl_version_from {
    my ( $self, $file ) = @_;

    if (
        $self->_slurp($file) =~ m/
        ^
        use \s*
        v?
        ([\d_\.]+)
        \s* ;
    /ixms
      )
    {
        my $v = $1;
        $v =~ s{_}{}g;
        $self->perl_version($1);
    }
    else {
        warn "Cannot determine perl version info from $file\n";
        return;
    }
}

sub author_from {
    my ( $self, $file ) = @_;
    my $content = $self->_slurp($file);
    if ($content =~ m/
        =head \d \s+ (?:authors?)\b \s*
        ([^\n]*)
        |
        =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
        .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
        ([^\n]*)
    /ixms) {
        my $author = $1 || $2;
        $author =~ s{E<lt>}{<}g;
        $author =~ s{E<gt>}{>}g;
        $self->author($author); 
    }
    else {
        warn "Cannot determine author info from $file\n";
    }
}

sub license_from {
    my ( $self, $file ) = @_;

    if (
        $self->_slurp($file) =~ m/
        =head \d \s+
        (?:licen[cs]e|licensing|copyright|legal)\b
        (.*?)
        (=head\\d.*|=cut.*|)
        \z
    /ixms
      )
    {
        my $license_text = $1;
        my @phrases      = (
            'under the same (?:terms|license) as perl itself' => 'perl',
            'GNU public license'                              => 'gpl',
            'GNU lesser public license'                       => 'gpl',
            'BSD license'                                     => 'bsd',
            'Artistic license'                                => 'artistic',
            'GPL'                                             => 'gpl',
            'LGPL'                                            => 'lgpl',
            'BSD'                                             => 'bsd',
            'Artistic'                                        => 'artistic',
        );
        while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
            $pattern =~ s{\s+}{\\s+}g;
            if ( $license_text =~ /\b$pattern\b/i ) {
                $self->license($license);
                return 1;
            }
        }
    }

    warn "Cannot determine license info from $file\n";
    return 'unknown';
}

1;
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.64';
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
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	sub 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
66	sub 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
76	sub 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
102	sub provides {
103	my $self = shift;
104	my $provides = ( $self->{values}{provides} \|\|= {} );
105	%$provides = (%$provides, @_) if @_;
106	return $provides;
107	}
108
109	sub 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
133	sub 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
162	sub 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
172	sub 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
179	sub 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
201	sub write {
202	my $self = shift;
203	return $self unless $self->is_admin;
204	$self->admin->write_meta;
205	return $self;
206	}
207
208	sub version_from {
209	my ( $self, $file ) = @_;
210	require ExtUtils::MM_Unix;
211	$self->version( ExtUtils::MM_Unix->parse_version($file) );
212	}
213
214	sub 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
225	sub _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
233	sub 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
256	sub 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
277	sub 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
315	1;