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.75';
        $ISCORE  = 1;
        @ISA     = qw{Module::Install::Base};
}

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

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

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;
        };
}

sub requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}->{requires} }, [ $module, $version ];
        }
        $self->{values}{requires};
}

sub build_requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}->{build_requires} }, [ $module, $version ];
        }
        $self->{values}{build_requires};
}

sub configure_requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
        }
        $self->{values}->{configure_requires};
}

sub recommends {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}->{recommends} }, [ $module, $version ];
        }
        $self->{values}->{recommends};
}

sub bundles {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}->{bundles} }, [ $module, $version ];
        }
        $self->{values}->{bundles};
}

# Resource handling
sub resources {
        my $self = shift;
        while ( @_ ) {
                my $resource = shift or last;
                my $value    = shift or next;
                push @{ $self->{values}->{resources} }, [ $resource, $value ];
        }
        $self->{values}->{resources};
}

sub repository {
        my $self = shift;
        $self->resources( repository => shift );
        return 1;
}

# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires      { shift->build_requires(@_) }
sub install_requires   { shift->build_requires(@_) }

# Aliases for installdirs options
sub install_as_core    { $_[0]->installdirs('perl')   }
sub install_as_cpan    { $_[0]->installdirs('site')   }
sub install_as_site    { $_[0]->installdirs('site')   }
sub install_as_vendor  { $_[0]->installdirs('vendor') }

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;
        }

        # Some methods pull from POD instead of code.
        # If there is a matching .pod, use that instead
        my $pod = $file;
        $pod =~ s/\.pm$/.pod/i;
        $pod = $file unless -e $pod;

        # Pull the different values
        $self->name_from($file)         unless $self->name;
        $self->version_from($file)      unless $self->version;
        $self->perl_version_from($file) unless $self->perl_version;
        $self->author_from($pod)        unless $self->author;
        $self->license_from($pod)       unless $self->license;
        $self->abstract_from($pod)      unless $self->abstract;

        return 1;
}

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::Tiny', 0 );

        require YAML::Tiny;
        my $data = YAML::Tiny::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 {
        require ExtUtils::MM_Unix;
        my ( $self, $file ) = @_;
        $self->version( ExtUtils::MM_Unix->parse_version($file) );
}

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

# Add both distribution and module name
sub name_from {
        my ($self, $file) = @_;
        if (
                Module::Install::_read($file) =~ m/
                ^ \s*
                package \s*
                ([\w:]+)
                \s* ;
                /ixms
        ) {
                my ($name, $module_name) = ($1, $1);
                $name =~ s{::}{-}g;
                $self->name($name);
                unless ( $self->module_name ) {
                        $self->module_name($module_name);
                }
        } else {
                die "Cannot determine name from $file\n";
        }
}

sub perl_version_from {
        my $self = shift;
        if (
                Module::Install::_read($_[0]) =~ m/
                ^
                (?:use|require) \s*
                v?
                ([\d_\.]+)
                \s* ;
                /ixms
        ) {
                my $perl_version = $1;
                $perl_version =~ s{_}{}g;
                $self->perl_version($perl_version);
        } else {
                warn "Cannot determine perl version info from $_[0]\n";
                return;
        }
}

sub author_from {
        my $self    = shift;
        my $content = Module::Install::_read($_[0]);
        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 $_[0]\n";
        }
}

sub license_from {
        my $self = shift;
        if (
                Module::Install::_read($_[0]) =~ 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',        1,
                        'GNU public license'                              => 'gpl',         1,
                        'GNU lesser public license'                       => 'lgpl',        1,
                        'BSD license'                                     => 'bsd',         1,
                        'Artistic license'                                => 'artistic',    1,
                        'GPL'                                             => 'gpl',         1,
                        'LGPL'                                            => 'lgpl',        1,
                        'BSD'                                             => 'bsd',         1,
                        'Artistic'                                        => 'artistic',    1,
                        'MIT'                                             => 'mit',         1,
                        'proprietary'                                     => 'proprietary', 0,
                );
                while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
                        $pattern =~ s{\s+}{\\s+}g;
                        if ( $license_text =~ /\b$pattern\b/i ) {
                                if ( $osi and $license_text =~ /All rights reserved/i ) {
                                        print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
                                }
                                $self->license($license);
                                return 1;
                        }
                }
        }

        warn "Cannot determine license info from $_[0]\n";
        return 'unknown';
}

sub install_script {
        my $self = shift;
        my $args = $self->makemaker_args;
        my $exe  = $args->{EXE_FILES} ||= [];
        foreach ( @_ ) {
                if ( -f $_ ) {
                        push @$exe, $_;
                } elsif ( -d 'script' and -f "script/$_" ) {
                        push @$exe, "script/$_";
                } else {
                        die "Cannot find script '$_'";
                }
        }
}

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.75';
10	$ISCORE = 1;
11	@ISA = qw{Module::Install::Base};
12	}
13
14	my @scalar_keys = qw{
15	name
16	module_name
17	abstract
18	author
19	version
20	license
21	distribution_type
22	perl_version
23	tests
24	installdirs
25	};
26
27	my @tuple_keys = qw{
28	configure_requires
29	build_requires
30	requires
31	recommends
32	bundles
33	resources
34	};
35
36	sub Meta { shift }
37	sub Meta_ScalarKeys { @scalar_keys }
38	sub Meta_TupleKeys { @tuple_keys }
39
40	foreach my $key (@scalar_keys) {
41	*$key = sub {
42	my $self = shift;
43	return $self->{values}{$key} if defined wantarray and !@_;
44	$self->{values}{$key} = shift;
45	return $self;
46	};
47	}
48
49	sub requires {
50	my $self = shift;
51	while ( @_ ) {
52	my $module = shift or last;
53	my $version = shift \|\| 0;
54	push @{ $self->{values}->{requires} }, [ $module, $version ];
55	}
56	$self->{values}{requires};
57	}
58
59	sub build_requires {
60	my $self = shift;
61	while ( @_ ) {
62	my $module = shift or last;
63	my $version = shift \|\| 0;
64	push @{ $self->{values}->{build_requires} }, [ $module, $version ];
65	}
66	$self->{values}{build_requires};
67	}
68
69	sub configure_requires {
70	my $self = shift;
71	while ( @_ ) {
72	my $module = shift or last;
73	my $version = shift \|\| 0;
74	push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
75	}
76	$self->{values}->{configure_requires};
77	}
78
79	sub recommends {
80	my $self = shift;
81	while ( @_ ) {
82	my $module = shift or last;
83	my $version = shift \|\| 0;
84	push @{ $self->{values}->{recommends} }, [ $module, $version ];
85	}
86	$self->{values}->{recommends};
87	}
88
89	sub bundles {
90	my $self = shift;
91	while ( @_ ) {
92	my $module = shift or last;
93	my $version = shift \|\| 0;
94	push @{ $self->{values}->{bundles} }, [ $module, $version ];
95	}
96	$self->{values}->{bundles};
97	}
98
99	# Resource handling
100	sub resources {
101	my $self = shift;
102	while ( @_ ) {
103	my $resource = shift or last;
104	my $value = shift or next;
105	push @{ $self->{values}->{resources} }, [ $resource, $value ];
106	}
107	$self->{values}->{resources};
108	}
109
110	sub repository {
111	my $self = shift;
112	$self->resources( repository => shift );
113	return 1;
114	}
115
116	# Aliases for build_requires that will have alternative
117	# meanings in some future version of META.yml.
118	sub test_requires { shift->build_requires(@_) }
119	sub install_requires { shift->build_requires(@_) }
120
121	# Aliases for installdirs options
122	sub install_as_core { $_[0]->installdirs('perl') }
123	sub install_as_cpan { $_[0]->installdirs('site') }
124	sub install_as_site { $_[0]->installdirs('site') }
125	sub install_as_vendor { $_[0]->installdirs('vendor') }
126
127	sub sign {
128	my $self = shift;
129	return $self->{'values'}{'sign'} if defined wantarray and ! @_;
130	$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
131	return $self;
132	}
133
134	sub dynamic_config {
135	my $self = shift;
136	unless ( @_ ) {
137	warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
138	return $self;
139	}
140	$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
141	return $self;
142	}
143
144	sub all_from {
145	my ( $self, $file ) = @_;
146
147	unless ( defined($file) ) {
148	my $name = $self->name
149	or die "all_from called with no args without setting name() first";
150	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
151	$file =~ s{.*/}{} unless -e $file;
152	die "all_from: cannot find $file from $name" unless -e $file;
153	}
154
155	# Some methods pull from POD instead of code.
156	# If there is a matching .pod, use that instead
157	my $pod = $file;
158	$pod =~ s/\.pm$/.pod/i;
159	$pod = $file unless -e $pod;
160
161	# Pull the different values
162	$self->name_from($file) unless $self->name;
163	$self->version_from($file) unless $self->version;
164	$self->perl_version_from($file) unless $self->perl_version;
165	$self->author_from($pod) unless $self->author;
166	$self->license_from($pod) unless $self->license;
167	$self->abstract_from($pod) unless $self->abstract;
168
169	return 1;
170	}
171
172	sub provides {
173	my $self = shift;
174	my $provides = ( $self->{values}{provides} \|\|= {} );
175	%$provides = (%$provides, @_) if @_;
176	return $provides;
177	}
178
179	sub auto_provides {
180	my $self = shift;
181	return $self unless $self->is_admin;
182	unless (-e 'MANIFEST') {
183	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
184	return $self;
185	}
186	# Avoid spurious warnings as we are not checking manifest here.
187	local $SIG{__WARN__} = sub {1};
188	require ExtUtils::Manifest;
189	local *ExtUtils::Manifest::manicheck = sub { return };
190
191	require Module::Build;
192	my $build = Module::Build->new(
193	dist_name => $self->name,
194	dist_version => $self->version,
195	license => $self->license,
196	);
197	$self->provides( %{ $build->find_dist_packages \|\| {} } );
198	}
199
200	sub feature {
201	my $self = shift;
202	my $name = shift;
203	my $features = ( $self->{values}{features} \|\|= [] );
204	my $mods;
205
206	if ( @_ == 1 and ref( $_[0] ) ) {
207	# The user used ->feature like ->features by passing in the second
208	# argument as a reference. Accomodate for that.
209	$mods = $_[0];
210	} else {
211	$mods = \@_;
212	}
213
214	my $count = 0;
215	push @$features, (
216	$name => [
217	map {
218	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
219	} @$mods
220	]
221	);
222
223	return @$features;
224	}
225
226	sub features {
227	my $self = shift;
228	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
229	$self->feature( $name, @$mods );
230	}
231	return $self->{values}->{features}
232	? @{ $self->{values}->{features} }
233	: ();
234	}
235
236	sub no_index {
237	my $self = shift;
238	my $type = shift;
239	push @{ $self->{values}{no_index}{$type} }, @_ if $type;
240	return $self->{values}{no_index};
241	}
242
243	sub read {
244	my $self = shift;
245	$self->include_deps( 'YAML::Tiny', 0 );
246
247	require YAML::Tiny;
248	my $data = YAML::Tiny::LoadFile('META.yml');
249
250	# Call methods explicitly in case user has already set some values.
251	while ( my ( $key, $value ) = each %$data ) {
252	next unless $self->can($key);
253	if ( ref $value eq 'HASH' ) {
254	while ( my ( $module, $version ) = each %$value ) {
255	$self->can($key)->($self, $module => $version );
256	}
257	} else {
258	$self->can($key)->($self, $value);
259	}
260	}
261	return $self;
262	}
263
264	sub write {
265	my $self = shift;
266	return $self unless $self->is_admin;
267	$self->admin->write_meta;
268	return $self;
269	}
270
271	sub version_from {
272	require ExtUtils::MM_Unix;
273	my ( $self, $file ) = @_;
274	$self->version( ExtUtils::MM_Unix->parse_version($file) );
275	}
276
277	sub abstract_from {
278	require ExtUtils::MM_Unix;
279	my ( $self, $file ) = @_;
280	$self->abstract(
281	bless(
282	{ DISTNAME => $self->name },
283	'ExtUtils::MM_Unix'
284	)->parse_abstract($file)
285	);
286	}
287
288	# Add both distribution and module name
289	sub name_from {
290	my ($self, $file) = @_;
291	if (
292	Module::Install::_read($file) =~ m/
293	^ \s*
294	package \s*
295	([\w:]+)
296	\s* ;
297	/ixms
298	) {
299	my ($name, $module_name) = ($1, $1);
300	$name =~ s{::}{-}g;
301	$self->name($name);
302	unless ( $self->module_name ) {
303	$self->module_name($module_name);
304	}
305	} else {
306	die "Cannot determine name from $file\n";
307	}
308	}
309
310	sub perl_version_from {
311	my $self = shift;
312	if (
313	Module::Install::_read($_[0]) =~ m/
314	^
315	(?:use\|require) \s*
316	v?
317	([\d_\.]+)
318	\s* ;
319	/ixms
320	) {
321	my $perl_version = $1;
322	$perl_version =~ s{_}{}g;
323	$self->perl_version($perl_version);
324	} else {
325	warn "Cannot determine perl version info from $_[0]\n";
326	return;
327	}
328	}
329
330	sub author_from {
331	my $self = shift;
332	my $content = Module::Install::_read($_[0]);
333	if ($content =~ m/
334	=head \d \s+ (?:authors?)\b \s*
335	([^\n]*)
336	\|
337	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
338	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
339	([^\n]*)
340	/ixms) {
341	my $author = $1 \|\| $2;
342	$author =~ s{E<lt>}{<}g;
343	$author =~ s{E<gt>}{>}g;
344	$self->author($author);
345	} else {
346	warn "Cannot determine author info from $_[0]\n";
347	}
348	}
349
350	sub license_from {
351	my $self = shift;
352	if (
353	Module::Install::_read($_[0]) =~ m/
354	(
355	=head \d \s+
356	(?:licen[cs]e\|licensing\|copyright\|legal)\b
357	.*?
358	)
359	(=head\\d.\|=cut.\|)
360	\z
361	/ixms ) {
362	my $license_text = $1;
363	my @phrases = (
364	'under the same (?:terms\|license) as perl itself' => 'perl', 1,
365	'GNU public license' => 'gpl', 1,
366	'GNU lesser public license' => 'lgpl', 1,
367	'BSD license' => 'bsd', 1,
368	'Artistic license' => 'artistic', 1,
369	'GPL' => 'gpl', 1,
370	'LGPL' => 'lgpl', 1,
371	'BSD' => 'bsd', 1,
372	'Artistic' => 'artistic', 1,
373	'MIT' => 'mit', 1,
374	'proprietary' => 'proprietary', 0,
375	);
376	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
377	$pattern =~ s{\s+}{\\s+}g;
378	if ( $license_text =~ /\b$pattern\b/i ) {
379	if ( $osi and $license_text =~ /All rights reserved/i ) {
380	print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
381	}
382	$self->license($license);
383	return 1;
384	}
385	}
386	}
387
388	warn "Cannot determine license info from $_[0]\n";
389	return 'unknown';
390	}
391
392	sub install_script {
393	my $self = shift;
394	my $args = $self->makemaker_args;
395	my $exe = $args->{EXE_FILES} \|\|= [];
396	foreach ( @_ ) {
397	if ( -f $_ ) {
398	push @$exe, $_;
399	} elsif ( -d 'script' and -f "script/$_" ) {
400	push @$exe, "script/$_";
401	} else {
402	die "Cannot find script '$_'";
403	}
404	}
405	}
406
407	1;