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