[gitmo/MooseX-MetaDescription.git] / inc / 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.68';
	$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{
    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;
    };
}

# configure_requires is currently a null-op
sub configure_requires { 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;
    }

    $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',        1,
            'GNU public license'                              => 'gpl',         1,
            'GNU lesser public license'                       => 'gpl',         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 ) {
                        warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
		}
                $self->license($license);
                return 1;
            }
        }
    }

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

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