Module/Install/Metadata.pm

#line 1
package Module::Install::Metadata;

use Module::Install::Base;
@ISA = qw{Module::Install::Base};

$VERSION = '0.61';

use strict 'vars';

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

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

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
      )
    {
        $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',
            'GNU public license'                              => 'gpl',
            'GNU lesser public license'                       => 'gpl',
            'BSD license'                                     => 'bsd',
            'Artistic license'                                => 'artistic',
            'GPL'                                             => 'gpl',
            'LGPL'                                            => 'lgpl',
            'BSD'                                             => 'bsd',
            'Artistic'                                        => 'artistic',
        );
        while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
            $pattern =~ s{\s+}{\\s+}g;
            if ( $license_text =~ /\b$pattern\b/i ) {
                $self->license($license);
                return 1;
            }
        }
    }

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

1;
1	dpavlin	1	#line 1
2			package Module::Install::Metadata;
3
4			use Module::Install::Base;
5			@ISA = qw{Module::Install::Base};
6
7			$VERSION = '0.61';
8
9			use strict 'vars';
10
11			my @scalar_keys = qw{
12			name module_name abstract author version license
13			distribution_type perl_version tests
14			};
15
16			my @tuple_keys = qw{
17			build_requires requires recommends bundles
18			};
19
20			sub Meta { shift }
21			sub Meta_ScalarKeys { @scalar_keys }
22			sub Meta_TupleKeys { @tuple_keys }
23
24			foreach my $key (@scalar_keys) {
25			*$key = sub {
26			my $self = shift;
27			return $self->{values}{$key} if defined wantarray and !@_;
28			$self->{values}{$key} = shift;
29			return $self;
30			};
31			}
32
33			foreach my $key (@tuple_keys) {
34			*$key = sub {
35			my $self = shift;
36			return $self->{values}{$key} unless @_;
37
38			my @rv;
39			while (@_) {
40			my $module = shift or last;
41			my $version = shift \|\| 0;
42			if ( $module eq 'perl' ) {
43			$version =~ s{^(\d+)\.(\d+)\.(\d+)}
44			{$1 + $2/1_000 + $3/1_000_000}e;
45			$self->perl_version($version);
46			next;
47			}
48			my $rv = [ $module, $version ];
49			push @rv, $rv;
50			}
51			push @{ $self->{values}{$key} }, @rv;
52			@rv;
53			};
54			}
55
56			sub sign {
57			my $self = shift;
58			return $self->{'values'}{'sign'} if defined wantarray and !@_;
59			$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
60			return $self;
61			}
62
63			sub dynamic_config {
64			my $self = shift;
65			unless ( @_ ) {
66			warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
67			return $self;
68			}
69			$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
70			return $self;
71			}
72
73			sub all_from {
74			my ( $self, $file ) = @_;
75
76			unless ( defined($file) ) {
77			my $name = $self->name
78			or die "all_from called with no args without setting name() first";
79			$file = join('/', 'lib', split(/-/, $name)) . '.pm';
80			$file =~ s{.*/}{} unless -e $file;
81			die "all_from: cannot find $file from $name" unless -e $file;
82			}
83
84			$self->version_from($file) unless $self->version;
85			$self->perl_version_from($file) unless $self->perl_version;
86
87			# The remaining probes read from POD sections; if the file
88			# has an accompanying .pod, use that instead
89			my $pod = $file;
90			if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
91			$file = $pod;
92			}
93
94			$self->author_from($file) unless $self->author;
95			$self->license_from($file) unless $self->license;
96			$self->abstract_from($file) unless $self->abstract;
97			}
98
99			sub provides {
100			my $self = shift;
101			my $provides = ( $self->{values}{provides} \|\|= {} );
102			%$provides = (%$provides, @_) if @_;
103			return $provides;
104			}
105
106			sub auto_provides {
107			my $self = shift;
108			return $self unless $self->is_admin;
109
110			unless (-e 'MANIFEST') {
111			warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
112			return $self;
113			}
114
115			# Avoid spurious warnings as we are not checking manifest here.
116
117			local $SIG{__WARN__} = sub {1};
118			require ExtUtils::Manifest;
119			local *ExtUtils::Manifest::manicheck = sub { return };
120
121			require Module::Build;
122			my $build = Module::Build->new(
123			dist_name => $self->{name},
124			dist_version => $self->{version},
125			license => $self->{license},
126			);
127			$self->provides(%{ $build->find_dist_packages \|\| {} });
128			}
129
130			sub feature {
131			my $self = shift;
132			my $name = shift;
133			my $features = ( $self->{values}{features} \|\|= [] );
134
135			my $mods;
136
137			if ( @_ == 1 and ref( $_[0] ) ) {
138			# The user used ->feature like ->features by passing in the second
139			# argument as a reference. Accomodate for that.
140			$mods = $_[0];
141			} else {
142			$mods = \@_;
143			}
144
145			my $count = 0;
146			push @$features, (
147			$name => [
148			map {
149			ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
150			: @$_
151			: $_
152			} @$mods
153			]
154			);
155
156			return @$features;
157			}
158
159			sub features {
160			my $self = shift;
161			while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
162			$self->feature( $name, @$mods );
163			}
164			return $self->{values}->{features}
165			? @{ $self->{values}->{features} }
166			: ();
167			}
168
169			sub no_index {
170			my $self = shift;
171			my $type = shift;
172			push @{ $self->{values}{no_index}{$type} }, @_ if $type;
173			return $self->{values}{no_index};
174			}
175
176			sub read {
177			my $self = shift;
178			$self->include_deps( 'YAML', 0 );
179
180			require YAML;
181			my $data = YAML::LoadFile('META.yml');
182
183			# Call methods explicitly in case user has already set some values.
184			while ( my ( $key, $value ) = each %$data ) {
185			next unless $self->can($key);
186			if ( ref $value eq 'HASH' ) {
187			while ( my ( $module, $version ) = each %$value ) {
188			$self->can($key)->($self, $module => $version );
189			}
190			}
191			else {
192			$self->can($key)->($self, $value);
193			}
194			}
195			return $self;
196			}
197
198			sub write {
199			my $self = shift;
200			return $self unless $self->is_admin;
201			$self->admin->write_meta;
202			return $self;
203			}
204
205			sub version_from {
206			my ( $self, $file ) = @_;
207			require ExtUtils::MM_Unix;
208			$self->version( ExtUtils::MM_Unix->parse_version($file) );
209			}
210
211			sub abstract_from {
212			my ( $self, $file ) = @_;
213			require ExtUtils::MM_Unix;
214			$self->abstract(
215			bless(
216			{ DISTNAME => $self->name },
217			'ExtUtils::MM_Unix'
218			)->parse_abstract($file)
219			);
220			}
221
222			sub _slurp {
223			my ( $self, $file ) = @_;
224
225			local *FH;
226			open FH, "< $file" or die "Cannot open $file.pod: $!";
227			do { local $/; <FH> };
228			}
229
230			sub perl_version_from {
231			my ( $self, $file ) = @_;
232
233			if (
234			$self->_slurp($file) =~ m/
235			^
236			use \s*
237			v?
238			([\d\.]+)
239			\s* ;
240			/ixms
241			)
242			{
243			$self->perl_version($1);
244			}
245			else {
246			warn "Cannot determine perl version info from $file\n";
247			return;
248			}
249			}
250
251			sub author_from {
252			my ( $self, $file ) = @_;
253			my $content = $self->_slurp($file);
254			if ($content =~ m/
255			=head \d \s+ (?:authors?)\b \s*
256			([^\n]*)
257			\|
258			=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
259			.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
260			([^\n]*)
261			/ixms) {
262			my $author = $1 \|\| $2;
263			$author =~ s{E<lt>}{<}g;
264			$author =~ s{E<gt>}{>}g;
265			$self->author($author);
266			}
267			else {
268			warn "Cannot determine author info from $file\n";
269			}
270			}
271
272			sub license_from {
273			my ( $self, $file ) = @_;
274
275			if (
276			$self->_slurp($file) =~ m/
277			=head \d \s+
278			(?:licen[cs]e\|licensing\|copyright\|legal)\b
279			(.*?)
280			(=head\\d.\|=cut.\|)
281			\z
282			/ixms
283			)
284			{
285			my $license_text = $1;
286			my @phrases = (
287			'under the same (?:terms\|license) as perl itself' => 'perl',
288			'GNU public license' => 'gpl',
289			'GNU lesser public license' => 'gpl',
290			'BSD license' => 'bsd',
291			'Artistic license' => 'artistic',
292			'GPL' => 'gpl',
293			'LGPL' => 'lgpl',
294			'BSD' => 'bsd',
295			'Artistic' => 'artistic',
296			);
297			while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
298			$pattern =~ s{\s+}{\\s+}g;
299			if ( $license_text =~ /\b$pattern\b/i ) {
300			$self->license($license);
301			return 1;
302			}
303			}
304			}
305
306			warn "Cannot determine license info from $file\n";
307			return 'unknown';
308			}
309
310			1;