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.67';
        $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;
1	dpavlin	34	#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.67';
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;