1#line 1
2package Module::Install::Metadata;
3
4use strict 'vars';
5use Module::Install::Base;
6
7use vars qw{$VERSION @ISA $ISCORE};
8BEGIN {
9	$VERSION = '0.87';
10	@ISA     = qw{Module::Install::Base};
11	$ISCORE  = 1;
12}
13
14my @boolean_keys = qw{
15	sign
16	mymeta
17};
18
19my @scalar_keys = qw{
20	name
21	module_name
22	abstract
23	author
24	version
25	distribution_type
26	tests
27	installdirs
28};
29
30my @tuple_keys = qw{
31	configure_requires
32	build_requires
33	requires
34	recommends
35	bundles
36	resources
37};
38
39my @resource_keys = qw{
40	homepage
41	bugtracker
42	repository
43};
44
45my @array_keys = qw{
46	keywords
47};
48
49sub Meta              { shift          }
50sub Meta_BooleanKeys  { @boolean_keys  }
51sub Meta_ScalarKeys   { @scalar_keys   }
52sub Meta_TupleKeys    { @tuple_keys    }
53sub Meta_ResourceKeys { @resource_keys }
54sub Meta_ArrayKeys    { @array_keys    }
55
56foreach my $key ( @boolean_keys ) {
57	*$key = sub {
58		my $self = shift;
59		if ( defined wantarray and not @_ ) {
60			return $self->{values}->{$key};
61		}
62		$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
63		return $self;
64	};
65}
66
67foreach my $key ( @scalar_keys ) {
68	*$key = sub {
69		my $self = shift;
70		return $self->{values}->{$key} if defined wantarray and !@_;
71		$self->{values}->{$key} = shift;
72		return $self;
73	};
74}
75
76foreach my $key ( @array_keys ) {
77	*$key = sub {
78		my $self = shift;
79		return $self->{values}->{$key} if defined wantarray and !@_;
80		$self->{values}->{$key} ||= [];
81		push @{$self->{values}->{$key}}, @_;
82		return $self;
83	};
84}
85
86foreach my $key ( @resource_keys ) {
87	*$key = sub {
88		my $self = shift;
89		unless ( @_ ) {
90			return () unless $self->{values}->{resources};
91			return map  { $_->[1] }
92			       grep { $_->[0] eq $key }
93			       @{ $self->{values}->{resources} };
94		}
95		return $self->{values}->{resources}->{$key} unless @_;
96		my $uri = shift or die(
97			"Did not provide a value to $key()"
98		);
99		$self->resources( $key => $uri );
100		return 1;
101	};
102}
103
104foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
105	*$key = sub {
106		my $self = shift;
107		return $self->{values}->{$key} unless @_;
108		my @added;
109		while ( @_ ) {
110			my $module  = shift or last;
111			my $version = shift || 0;
112			push @added, [ $module, $version ];
113		}
114		push @{ $self->{values}->{$key} }, @added;
115		return map {@$_} @added;
116	};
117}
118
119# Resource handling
120my %lc_resource = map { $_ => 1 } qw{
121	homepage
122	license
123	bugtracker
124	repository
125};
126
127sub resources {
128	my $self = shift;
129	while ( @_ ) {
130		my $name  = shift or last;
131		my $value = shift or next;
132		if ( $name eq lc $name and ! $lc_resource{$name} ) {
133			die("Unsupported reserved lowercase resource '$name'");
134		}
135		$self->{values}->{resources} ||= [];
136		push @{ $self->{values}->{resources} }, [ $name, $value ];
137	}
138	$self->{values}->{resources};
139}
140
141# Aliases for build_requires that will have alternative
142# meanings in some future version of META.yml.
143sub test_requires     { shift->build_requires(@_) }
144sub install_requires  { shift->build_requires(@_) }
145
146# Aliases for installdirs options
147sub install_as_core   { $_[0]->installdirs('perl')   }
148sub install_as_cpan   { $_[0]->installdirs('site')   }
149sub install_as_site   { $_[0]->installdirs('site')   }
150sub install_as_vendor { $_[0]->installdirs('vendor') }
151
152sub dynamic_config {
153	my $self = shift;
154	unless ( @_ ) {
155		warn "You MUST provide an explicit true/false value to dynamic_config\n";
156		return $self;
157	}
158	$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
159	return 1;
160}
161
162sub perl_version {
163	my $self = shift;
164	return $self->{values}->{perl_version} unless @_;
165	my $version = shift or die(
166		"Did not provide a value to perl_version()"
167	);
168
169	# Normalize the version
170	$version = $self->_perl_version($version);
171
172	# We don't support the reall old versions
173	unless ( $version >= 5.005 ) {
174		die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
175	}
176
177	$self->{values}->{perl_version} = $version;
178}
179
180#Stolen from M::B
181my %license_urls = (
182    perl         => 'http://dev.perl.org/licenses/',
183    apache       => 'http://apache.org/licenses/LICENSE-2.0',
184    artistic     => 'http://opensource.org/licenses/artistic-license.php',
185    artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
186    lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
187    lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
188    lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
189    bsd          => 'http://opensource.org/licenses/bsd-license.php',
190    gpl          => 'http://opensource.org/licenses/gpl-license.php',
191    gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
192    gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
193    mit          => 'http://opensource.org/licenses/mit-license.php',
194    mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
195    open_source  => undef,
196    unrestricted => undef,
197    restrictive  => undef,
198    unknown      => undef,
199);
200
201sub license {
202	my $self = shift;
203	return $self->{values}->{license} unless @_;
204	my $license = shift or die(
205		'Did not provide a value to license()'
206	);
207	$self->{values}->{license} = $license;
208
209	# Automatically fill in license URLs
210	if ( $license_urls{$license} ) {
211		$self->resources( license => $license_urls{$license} );
212	}
213
214	return 1;
215}
216
217sub all_from {
218	my ( $self, $file ) = @_;
219
220	unless ( defined($file) ) {
221		my $name = $self->name or die(
222			"all_from called with no args without setting name() first"
223		);
224		$file = join('/', 'lib', split(/-/, $name)) . '.pm';
225		$file =~ s{.*/}{} unless -e $file;
226		unless ( -e $file ) {
227			die("all_from cannot find $file from $name");
228		}
229	}
230	unless ( -f $file ) {
231		die("The path '$file' does not exist, or is not a file");
232	}
233
234	# Some methods pull from POD instead of code.
235	# If there is a matching .pod, use that instead
236	my $pod = $file;
237	$pod =~ s/\.pm$/.pod/i;
238	$pod = $file unless -e $pod;
239
240	# Pull the different values
241	$self->name_from($file)         unless $self->name;
242	$self->version_from($file)      unless $self->version;
243	$self->perl_version_from($file) unless $self->perl_version;
244	$self->author_from($pod)        unless $self->author;
245	$self->license_from($pod)       unless $self->license;
246	$self->abstract_from($pod)      unless $self->abstract;
247
248	return 1;
249}
250
251sub provides {
252	my $self     = shift;
253	my $provides = ( $self->{values}->{provides} ||= {} );
254	%$provides = (%$provides, @_) if @_;
255	return $provides;
256}
257
258sub auto_provides {
259	my $self = shift;
260	return $self unless $self->is_admin;
261	unless (-e 'MANIFEST') {
262		warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
263		return $self;
264	}
265	# Avoid spurious warnings as we are not checking manifest here.
266	local $SIG{__WARN__} = sub {1};
267	require ExtUtils::Manifest;
268	local *ExtUtils::Manifest::manicheck = sub { return };
269
270	require Module::Build;
271	my $build = Module::Build->new(
272		dist_name    => $self->name,
273		dist_version => $self->version,
274		license      => $self->license,
275	);
276	$self->provides( %{ $build->find_dist_packages || {} } );
277}
278
279sub feature {
280	my $self     = shift;
281	my $name     = shift;
282	my $features = ( $self->{values}->{features} ||= [] );
283	my $mods;
284
285	if ( @_ == 1 and ref( $_[0] ) ) {
286		# The user used ->feature like ->features by passing in the second
287		# argument as a reference.  Accomodate for that.
288		$mods = $_[0];
289	} else {
290		$mods = \@_;
291	}
292
293	my $count = 0;
294	push @$features, (
295		$name => [
296			map {
297				ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
298			} @$mods
299		]
300	);
301
302	return @$features;
303}
304
305sub features {
306	my $self = shift;
307	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
308		$self->feature( $name, @$mods );
309	}
310	return $self->{values}->{features}
311		? @{ $self->{values}->{features} }
312		: ();
313}
314
315sub no_index {
316	my $self = shift;
317	my $type = shift;
318	push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
319	return $self->{values}->{no_index};
320}
321
322sub read {
323	my $self = shift;
324	$self->include_deps( 'YAML::Tiny', 0 );
325
326	require YAML::Tiny;
327	my $data = YAML::Tiny::LoadFile('META.yml');
328
329	# Call methods explicitly in case user has already set some values.
330	while ( my ( $key, $value ) = each %$data ) {
331		next unless $self->can($key);
332		if ( ref $value eq 'HASH' ) {
333			while ( my ( $module, $version ) = each %$value ) {
334				$self->can($key)->($self, $module => $version );
335			}
336		} else {
337			$self->can($key)->($self, $value);
338		}
339	}
340	return $self;
341}
342
343sub write {
344	my $self = shift;
345	return $self unless $self->is_admin;
346	$self->admin->write_meta;
347	return $self;
348}
349
350sub version_from {
351	require ExtUtils::MM_Unix;
352	my ( $self, $file ) = @_;
353	$self->version( ExtUtils::MM_Unix->parse_version($file) );
354}
355
356sub abstract_from {
357	require ExtUtils::MM_Unix;
358	my ( $self, $file ) = @_;
359	$self->abstract(
360		bless(
361			{ DISTNAME => $self->name },
362			'ExtUtils::MM_Unix'
363		)->parse_abstract($file)
364	 );
365}
366
367# Add both distribution and module name
368sub name_from {
369	my ($self, $file) = @_;
370	if (
371		Module::Install::_read($file) =~ m/
372		^ \s*
373		package \s*
374		([\w:]+)
375		\s* ;
376		/ixms
377	) {
378		my ($name, $module_name) = ($1, $1);
379		$name =~ s{::}{-}g;
380		$self->name($name);
381		unless ( $self->module_name ) {
382			$self->module_name($module_name);
383		}
384	} else {
385		die("Cannot determine name from $file\n");
386	}
387}
388
389sub perl_version_from {
390	my $self = shift;
391	if (
392		Module::Install::_read($_[0]) =~ m/
393		^
394		(?:use|require) \s*
395		v?
396		([\d_\.]+)
397		\s* ;
398		/ixms
399	) {
400		my $perl_version = $1;
401		$perl_version =~ s{_}{}g;
402		$self->perl_version($perl_version);
403	} else {
404		warn "Cannot determine perl version info from $_[0]\n";
405		return;
406	}
407}
408
409sub author_from {
410	my $self    = shift;
411	my $content = Module::Install::_read($_[0]);
412	if ($content =~ m/
413		=head \d \s+ (?:authors?)\b \s*
414		([^\n]*)
415		|
416		=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
417		.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
418		([^\n]*)
419	/ixms) {
420		my $author = $1 || $2;
421		$author =~ s{E<lt>}{<}g;
422		$author =~ s{E<gt>}{>}g;
423		$self->author($author);
424	} else {
425		warn "Cannot determine author info from $_[0]\n";
426	}
427}
428
429sub license_from {
430	my $self = shift;
431	if (
432		Module::Install::_read($_[0]) =~ m/
433		(
434			=head \d \s+
435			(?:licen[cs]e|licensing|copyright|legal)\b
436			.*?
437		)
438		(=head\\d.*|=cut.*|)
439		\z
440	/ixms ) {
441		my $license_text = $1;
442		my @phrases      = (
443			'under the same (?:terms|license) as perl itself' => 'perl',        1,
444			'GNU general public license'                      => 'gpl',         1,
445			'GNU public license'                              => 'gpl',         1,
446			'GNU lesser general public license'               => 'lgpl',        1,
447			'GNU lesser public license'                       => 'lgpl',        1,
448			'GNU library general public license'              => 'lgpl',        1,
449			'GNU library public license'                      => 'lgpl',        1,
450			'BSD license'                                     => 'bsd',         1,
451			'Artistic license'                                => 'artistic',    1,
452			'GPL'                                             => 'gpl',         1,
453			'LGPL'                                            => 'lgpl',        1,
454			'BSD'                                             => 'bsd',         1,
455			'Artistic'                                        => 'artistic',    1,
456			'MIT'                                             => 'mit',         1,
457			'proprietary'                                     => 'proprietary', 0,
458		);
459		while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
460			$pattern =~ s{\s+}{\\s+}g;
461			if ( $license_text =~ /\b$pattern\b/i ) {
462				$self->license($license);
463				return 1;
464			}
465		}
466	}
467
468	warn "Cannot determine license info from $_[0]\n";
469	return 'unknown';
470}
471
472sub _extract_bugtracker {
473	my @links   = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
474	my %links;
475	@links{@links}=();
476	@links=keys %links;
477	return @links;
478}
479
480sub bugtracker_from {
481	my $self    = shift;
482	my $content = Module::Install::_read($_[0]);
483	my @links   = _extract_bugtracker($content);
484	unless ( @links ) {
485		warn "Cannot determine bugtracker info from $_[0]\n";
486		return 0;
487	}
488	if ( @links > 1 ) {
489		warn "Found more than on rt.cpan.org link in $_[0]\n";
490		return 0;
491	}
492
493	# Set the bugtracker
494	bugtracker( $links[0] );
495	return 1;
496}
497
498sub requires_from {
499	my $self     = shift;
500	my $content  = Module::Install::_readperl($_[0]);
501	my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
502	while ( @requires ) {
503		my $module  = shift @requires;
504		my $version = shift @requires;
505		$self->requires( $module => $version );
506	}
507}
508
509# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
510# numbers (eg, 5.006001 or 5.008009).
511# Also, convert double-part versions (eg, 5.8)
512sub _perl_version {
513	my $v = $_[-1];
514	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
515	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
516	$v =~ s/(\.\d\d\d)000$/$1/;
517	$v =~ s/_.+$//;
518	if ( ref($v) ) {
519		$v = $v + 0; # Numify
520	}
521	return $v;
522}
523
524
525
526
527
528######################################################################
529# MYMETA.yml Support
530
531sub WriteMyMeta {
532	die "WriteMyMeta has been deprecated";
533}
534
535sub write_mymeta {
536	my $self = shift;
537
538	# If there's no existing META.yml there is nothing we can do
539	return unless -f 'META.yml';
540
541	# We need YAML::Tiny to write the MYMETA.yml file
542	unless ( eval { require YAML::Tiny; 1; } ) {
543		return 1;
544	}
545
546	# Merge the perl version into the dependencies
547	my $val  = $self->Meta->{values};
548	my $perl = delete $val->{perl_version};
549	if ( $perl ) {
550		$val->{requires} ||= [];
551		my $requires = $val->{requires};
552
553		# Canonize to three-dot version after Perl 5.6
554		if ( $perl >= 5.006 ) {
555			$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
556		}
557		unshift @$requires, [ perl => $perl ];
558	}
559
560	# Load the advisory META.yml file
561	my @yaml = YAML::Tiny::LoadFile('META.yml');
562	my $meta = $yaml[0];
563
564	# Overwrite the non-configure dependency hashs
565	delete $meta->{requires};
566	delete $meta->{build_requires};
567	delete $meta->{recommends};
568	if ( exists $val->{requires} ) {
569		$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
570	}
571	if ( exists $val->{build_requires} ) {
572		$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
573	}
574
575	# Save as the MYMETA.yml file
576	print "Writing MYMETA.yml\n";
577	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
578}
579
5801;
581