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.76';
        $ISCORE  = 1;
        @ISA     = qw{Module::Install::Base};
}

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

my @tuple_keys = qw{
        configure_requires
        build_requires
        requires
        recommends
        bundles
        resources
};

my @resource_keys = qw{
        homepage
        bugtracker
        repository
};

sub Meta              { shift          }
sub Meta_ScalarKeys   { @scalar_keys   }
sub Meta_TupleKeys    { @tuple_keys    }
sub Meta_ResourceKeys { @resource_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 ( @resource_keys ) {
        *$key = sub {
                my $self = shift;
                unless ( @_ ) {
                        return () unless $self->{values}{resources};
                        return map  { $_->[1] }
                               grep { $_->[0] eq $key }
                               @{ $self->{values}{resources} };
                }
                return $self->{values}{resources}{$key} unless @_;
                my $uri = shift or die(
                        "Did not provide a value to $key()"
                );
                $self->resources( $key => $uri );
                return 1;
        };
}

sub requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}{requires} }, [ $module, $version ];
        }
        $self->{values}{requires};
}

sub build_requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}{build_requires} }, [ $module, $version ];
        }
        $self->{values}{build_requires};
}

sub configure_requires {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}{configure_requires} }, [ $module, $version ];
        }
        $self->{values}{configure_requires};
}

sub recommends {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}{recommends} }, [ $module, $version ];
        }
        $self->{values}{recommends};
}

sub bundles {
        my $self = shift;
        while ( @_ ) {
                my $module  = shift or last;
                my $version = shift || 0;
                push @{ $self->{values}{bundles} }, [ $module, $version ];
        }
        $self->{values}{bundles};
}

# Resource handling
my %lc_resource = map { $_ => 1 } qw{
        homepage
        license
        bugtracker
        repository
};

sub resources {
        my $self = shift;
        while ( @_ ) {
                my $name  = shift or last;
                my $value = shift or next;
                if ( $name eq lc $name and ! $lc_resource{$name} ) {
                        die("Unsupported reserved lowercase resource '$name'");
                }
                $self->{values}{resources} ||= [];
                push @{ $self->{values}{resources} }, [ $name, $value ];
        }
        $self->{values}{resources};
}

# 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\n";
                return $self;
        }
        $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
        return 1;
}

sub perl_version {
        my $self = shift;
        return $self->{values}{perl_version} unless @_;
        my $version = shift or die(
                "Did not provide a value to perl_version()"
        );
        $version =~ s/_.+$//;
        $version = $version + 0; # Numify
        unless ( $version >= 5.005 ) {
                die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
        }
        $self->{values}{perl_version} = $version;
        return 1;
}

sub license {
        my $self = shift;
        return $self->{values}{license} unless @_;
        my $license = shift or die(
                'Did not provide a value to license()'
        );
        $self->{values}{license} = $license;

        # Automatically fill in license URLs
        if ( $license eq 'perl' ) {
                $self->resources( license => 'http://dev.perl.org/licenses/' );
        }

        return 1;
}

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;
                unless ( -e $file ) {
                        die("all_from cannot find $file from $name");
                }
        }

        # Some methods pull from POD instead of code.
        # If there is a matching .pod, use that instead
        my $pod = $file;
        $pod =~ s/\.pm$/.pod/i;
        $pod = $file unless -e $pod;

        # Pull the different values
        $self->name_from($file)         unless $self->name;
        $self->version_from($file)      unless $self->version;
        $self->perl_version_from($file) unless $self->perl_version;
        $self->author_from($pod)        unless $self->author;
        $self->license_from($pod)       unless $self->license;
        $self->abstract_from($pod)      unless $self->abstract;

        return 1;
}

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::Tiny', 0 );

        require YAML::Tiny;
        my $data = YAML::Tiny::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 {
        require ExtUtils::MM_Unix;
        my ( $self, $file ) = @_;
        $self->version( ExtUtils::MM_Unix->parse_version($file) );
}

sub abstract_from {
        require ExtUtils::MM_Unix;
        my ( $self, $file ) = @_;
        $self->abstract(
                bless(
                        { DISTNAME => $self->name },
                        'ExtUtils::MM_Unix'
                )->parse_abstract($file)
         );
}

# Add both distribution and module name
sub name_from {
        my ($self, $file) = @_;
        if (
                Module::Install::_read($file) =~ m/
                ^ \s*
                package \s*
                ([\w:]+)
                \s* ;
                /ixms
        ) {
                my ($name, $module_name) = ($1, $1);
                $name =~ s{::}{-}g;
                $self->name($name);
                unless ( $self->module_name ) {
                        $self->module_name($module_name);
                }
        } else {
                die("Cannot determine name from $file\n");
        }
}

sub perl_version_from {
        my $self = shift;
        if (
                Module::Install::_read($_[0]) =~ m/
                ^
                (?:use|require) \s*
                v?
                ([\d_\.]+)
                \s* ;
                /ixms
        ) {
                my $perl_version = $1;
                $perl_version =~ s{_}{}g;
                $self->perl_version($perl_version);
        } else {
                warn "Cannot determine perl version info from $_[0]\n";
                return;
        }
}

sub author_from {
        my $self    = shift;
        my $content = Module::Install::_read($_[0]);
        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 $_[0]\n";
        }
}

sub license_from {
        my $self = shift;
        if (
                Module::Install::_read($_[0]) =~ 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'                       => 'lgpl',        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 ) {
                                        print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
                                }
                                $self->license($license);
                                return 1;
                        }
                }
        }

        warn "Cannot determine license info from $_[0]\n";
        return 'unknown';
}

sub bugtracker_from {
        my $self    = shift;
        my $content = Module::Install::_read($_[0]);
        my @links   = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
        unless ( @links ) {
                warn "Cannot determine bugtracker info from $_[0]\n";
                return 0;
        }
        if ( @links > 1 ) {
                warn "Found more than on rt.cpan.org link in $_[0]\n";
                return 0;
        }

        # Set the bugtracker
        bugtracker( $links[0] );
        return 1;
}

sub install_script {
        my $self = shift;
        my $args = $self->makemaker_args;
        my $exe  = $args->{EXE_FILES} ||= [];
        foreach ( @_ ) {
                if ( -f $_ ) {
                        push @$exe, $_;
                } elsif ( -d 'script' and -f "script/$_" ) {
                        push @$exe, "script/$_";
                } else {
                        die("Cannot find script '$_'");
                }
        }
}

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	dpavlin	52	$VERSION = '0.76';
10	dpavlin	34	$ISCORE = 1;
11			@ISA = qw{Module::Install::Base};
12			}
13
14			my @scalar_keys = qw{
15	dpavlin	52	name
16			module_name
17			abstract
18			author
19			version
20			distribution_type
21			tests
22			installdirs
23	dpavlin	34	};
24
25			my @tuple_keys = qw{
26	dpavlin	52	configure_requires
27			build_requires
28			requires
29			recommends
30			bundles
31			resources
32	dpavlin	34	};
33
34	dpavlin	52	my @resource_keys = qw{
35			homepage
36			bugtracker
37			repository
38			};
39	dpavlin	34
40	dpavlin	52	sub Meta { shift }
41			sub Meta_ScalarKeys { @scalar_keys }
42			sub Meta_TupleKeys { @tuple_keys }
43			sub Meta_ResourceKeys { @resource_keys }
44
45			foreach my $key ( @scalar_keys ) {
46			*$key = sub {
47			my $self = shift;
48			return $self->{values}{$key} if defined wantarray and !@_;
49			$self->{values}{$key} = shift;
50			return $self;
51			};
52	dpavlin	34	}
53
54	dpavlin	52	foreach my $key ( @resource_keys ) {
55			*$key = sub {
56			my $self = shift;
57			unless ( @_ ) {
58			return () unless $self->{values}{resources};
59			return map { $_->[1] }
60			grep { $_->[0] eq $key }
61			@{ $self->{values}{resources} };
62			}
63			return $self->{values}{resources}{$key} unless @_;
64			my $uri = shift or die(
65			"Did not provide a value to $key()"
66			);
67			$self->resources( $key => $uri );
68			return 1;
69			};
70			}
71	dpavlin	34
72	dpavlin	52	sub requires {
73			my $self = shift;
74			while ( @_ ) {
75			my $module = shift or last;
76			my $version = shift \|\| 0;
77			push @{ $self->{values}{requires} }, [ $module, $version ];
78			}
79			$self->{values}{requires};
80	dpavlin	34	}
81
82	dpavlin	52	sub build_requires {
83			my $self = shift;
84			while ( @_ ) {
85			my $module = shift or last;
86			my $version = shift \|\| 0;
87			push @{ $self->{values}{build_requires} }, [ $module, $version ];
88			}
89			$self->{values}{build_requires};
90			}
91	dpavlin	34
92	dpavlin	52	sub configure_requires {
93			my $self = shift;
94			while ( @_ ) {
95			my $module = shift or last;
96			my $version = shift \|\| 0;
97			push @{ $self->{values}{configure_requires} }, [ $module, $version ];
98			}
99			$self->{values}{configure_requires};
100			}
101
102			sub recommends {
103			my $self = shift;
104			while ( @_ ) {
105			my $module = shift or last;
106			my $version = shift \|\| 0;
107			push @{ $self->{values}{recommends} }, [ $module, $version ];
108			}
109			$self->{values}{recommends};
110			}
111
112			sub bundles {
113			my $self = shift;
114			while ( @_ ) {
115			my $module = shift or last;
116			my $version = shift \|\| 0;
117			push @{ $self->{values}{bundles} }, [ $module, $version ];
118			}
119			$self->{values}{bundles};
120			}
121
122			# Resource handling
123			my %lc_resource = map { $_ => 1 } qw{
124			homepage
125			license
126			bugtracker
127			repository
128			};
129
130			sub resources {
131			my $self = shift;
132			while ( @_ ) {
133			my $name = shift or last;
134			my $value = shift or next;
135			if ( $name eq lc $name and ! $lc_resource{$name} ) {
136			die("Unsupported reserved lowercase resource '$name'");
137			}
138			$self->{values}{resources} \|\|= [];
139			push @{ $self->{values}{resources} }, [ $name, $value ];
140			}
141			$self->{values}{resources};
142			}
143
144	dpavlin	34	# Aliases for build_requires that will have alternative
145			# meanings in some future version of META.yml.
146	dpavlin	52	sub test_requires { shift->build_requires(@_) }
147			sub install_requires { shift->build_requires(@_) }
148	dpavlin	34
149			# Aliases for installdirs options
150			sub install_as_core { $_[0]->installdirs('perl') }
151			sub install_as_cpan { $_[0]->installdirs('site') }
152			sub install_as_site { $_[0]->installdirs('site') }
153			sub install_as_vendor { $_[0]->installdirs('vendor') }
154
155			sub sign {
156	dpavlin	52	my $self = shift;
157			return $self->{values}{sign} if defined wantarray and ! @_;
158			$self->{values}{sign} = ( @_ ? $_[0] : 1 );
159			return $self;
160	dpavlin	34	}
161
162			sub dynamic_config {
163			my $self = shift;
164			unless ( @_ ) {
165	dpavlin	52	warn "You MUST provide an explicit true/false value to dynamic_config\n";
166	dpavlin	34	return $self;
167			}
168	dpavlin	52	$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
169			return 1;
170	dpavlin	34	}
171
172	dpavlin	52	sub perl_version {
173			my $self = shift;
174			return $self->{values}{perl_version} unless @_;
175			my $version = shift or die(
176			"Did not provide a value to perl_version()"
177			);
178			$version =~ s/_.+$//;
179			$version = $version + 0; # Numify
180			unless ( $version >= 5.005 ) {
181			die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
182			}
183			$self->{values}{perl_version} = $version;
184			return 1;
185			}
186
187			sub license {
188			my $self = shift;
189			return $self->{values}{license} unless @_;
190			my $license = shift or die(
191			'Did not provide a value to license()'
192			);
193			$self->{values}{license} = $license;
194
195			# Automatically fill in license URLs
196			if ( $license eq 'perl' ) {
197			$self->resources( license => 'http://dev.perl.org/licenses/' );
198			}
199
200			return 1;
201			}
202
203	dpavlin	34	sub all_from {
204	dpavlin	52	my ( $self, $file ) = @_;
205	dpavlin	34
206	dpavlin	52	unless ( defined($file) ) {
207			my $name = $self->name or die(
208			"all_from called with no args without setting name() first"
209			);
210			$file = join('/', 'lib', split(/-/, $name)) . '.pm';
211			$file =~ s{.*/}{} unless -e $file;
212			unless ( -e $file ) {
213			die("all_from cannot find $file from $name");
214			}
215			}
216	dpavlin	34
217	dpavlin	52	# Some methods pull from POD instead of code.
218			# If there is a matching .pod, use that instead
219			my $pod = $file;
220			$pod =~ s/\.pm$/.pod/i;
221			$pod = $file unless -e $pod;
222	dpavlin	34
223	dpavlin	52	# Pull the different values
224			$self->name_from($file) unless $self->name;
225			$self->version_from($file) unless $self->version;
226			$self->perl_version_from($file) unless $self->perl_version;
227			$self->author_from($pod) unless $self->author;
228			$self->license_from($pod) unless $self->license;
229			$self->abstract_from($pod) unless $self->abstract;
230	dpavlin	34
231	dpavlin	52	return 1;
232	dpavlin	34	}
233
234			sub provides {
235	dpavlin	52	my $self = shift;
236			my $provides = ( $self->{values}{provides} \|\|= {} );
237			%$provides = (%$provides, @_) if @_;
238			return $provides;
239	dpavlin	34	}
240
241			sub auto_provides {
242	dpavlin	52	my $self = shift;
243			return $self unless $self->is_admin;
244			unless (-e 'MANIFEST') {
245			warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
246			return $self;
247			}
248			# Avoid spurious warnings as we are not checking manifest here.
249			local $SIG{__WARN__} = sub {1};
250			require ExtUtils::Manifest;
251			local *ExtUtils::Manifest::manicheck = sub { return };
252	dpavlin	34
253	dpavlin	52	require Module::Build;
254			my $build = Module::Build->new(
255			dist_name => $self->name,
256			dist_version => $self->version,
257			license => $self->license,
258			);
259			$self->provides( %{ $build->find_dist_packages \|\| {} } );
260	dpavlin	34	}
261
262			sub feature {
263	dpavlin	52	my $self = shift;
264			my $name = shift;
265			my $features = ( $self->{values}{features} \|\|= [] );
266			my $mods;
267	dpavlin	34
268	dpavlin	52	if ( @_ == 1 and ref( $_[0] ) ) {
269			# The user used ->feature like ->features by passing in the second
270			# argument as a reference. Accomodate for that.
271			$mods = $_[0];
272			} else {
273			$mods = \@_;
274			}
275	dpavlin	34
276	dpavlin	52	my $count = 0;
277			push @$features, (
278			$name => [
279			map {
280			ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
281			} @$mods
282			]
283			);
284	dpavlin	34
285	dpavlin	52	return @$features;
286	dpavlin	34	}
287
288			sub features {
289	dpavlin	52	my $self = shift;
290			while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
291			$self->feature( $name, @$mods );
292			}
293			return $self->{values}{features}
294			? @{ $self->{values}{features} }
295			: ();
296	dpavlin	34	}
297
298			sub no_index {
299	dpavlin	52	my $self = shift;
300			my $type = shift;
301			push @{ $self->{values}{no_index}{$type} }, @_ if $type;
302			return $self->{values}{no_index};
303	dpavlin	34	}
304
305			sub read {
306	dpavlin	52	my $self = shift;
307			$self->include_deps( 'YAML::Tiny', 0 );
308	dpavlin	34
309	dpavlin	52	require YAML::Tiny;
310			my $data = YAML::Tiny::LoadFile('META.yml');
311	dpavlin	34
312	dpavlin	52	# Call methods explicitly in case user has already set some values.
313			while ( my ( $key, $value ) = each %$data ) {
314			next unless $self->can($key);
315			if ( ref $value eq 'HASH' ) {
316			while ( my ( $module, $version ) = each %$value ) {
317			$self->can($key)->($self, $module => $version );
318			}
319			} else {
320			$self->can($key)->($self, $value);
321			}
322			}
323			return $self;
324	dpavlin	34	}
325
326			sub write {
327	dpavlin	52	my $self = shift;
328			return $self unless $self->is_admin;
329			$self->admin->write_meta;
330			return $self;
331	dpavlin	34	}
332
333			sub version_from {
334	dpavlin	52	require ExtUtils::MM_Unix;
335			my ( $self, $file ) = @_;
336			$self->version( ExtUtils::MM_Unix->parse_version($file) );
337	dpavlin	34	}
338
339			sub abstract_from {
340	dpavlin	52	require ExtUtils::MM_Unix;
341			my ( $self, $file ) = @_;
342			$self->abstract(
343			bless(
344			{ DISTNAME => $self->name },
345			'ExtUtils::MM_Unix'
346			)->parse_abstract($file)
347			);
348	dpavlin	34	}
349
350	dpavlin	52	# Add both distribution and module name
351			sub name_from {
352			my ($self, $file) = @_;
353			if (
354			Module::Install::_read($file) =~ m/
355			^ \s*
356			package \s*
357			([\w:]+)
358			\s* ;
359			/ixms
360			) {
361			my ($name, $module_name) = ($1, $1);
362			$name =~ s{::}{-}g;
363			$self->name($name);
364			unless ( $self->module_name ) {
365			$self->module_name($module_name);
366			}
367			} else {
368			die("Cannot determine name from $file\n");
369			}
370	dpavlin	34	}
371
372			sub perl_version_from {
373	dpavlin	52	my $self = shift;
374			if (
375			Module::Install::_read($_[0]) =~ m/
376			^
377			(?:use\|require) \s*
378			v?
379			([\d_\.]+)
380			\s* ;
381			/ixms
382			) {
383			my $perl_version = $1;
384			$perl_version =~ s{_}{}g;
385			$self->perl_version($perl_version);
386			} else {
387			warn "Cannot determine perl version info from $_[0]\n";
388			return;
389			}
390	dpavlin	34	}
391
392			sub author_from {
393	dpavlin	52	my $self = shift;
394			my $content = Module::Install::_read($_[0]);
395			if ($content =~ m/
396			=head \d \s+ (?:authors?)\b \s*
397			([^\n]*)
398			\|
399			=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
400			.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
401			([^\n]*)
402			/ixms) {
403			my $author = $1 \|\| $2;
404			$author =~ s{E<lt>}{<}g;
405			$author =~ s{E<gt>}{>}g;
406			$self->author($author);
407			} else {
408			warn "Cannot determine author info from $_[0]\n";
409			}
410	dpavlin	34	}
411
412			sub license_from {
413	dpavlin	52	my $self = shift;
414			if (
415			Module::Install::_read($_[0]) =~ m/
416			(
417			=head \d \s+
418			(?:licen[cs]e\|licensing\|copyright\|legal)\b
419			.*?
420			)
421			(=head\\d.\|=cut.\|)
422			\z
423			/ixms ) {
424			my $license_text = $1;
425			my @phrases = (
426			'under the same (?:terms\|license) as perl itself' => 'perl', 1,
427			'GNU public license' => 'gpl', 1,
428			'GNU lesser public license' => 'lgpl', 1,
429			'BSD license' => 'bsd', 1,
430			'Artistic license' => 'artistic', 1,
431			'GPL' => 'gpl', 1,
432			'LGPL' => 'lgpl', 1,
433			'BSD' => 'bsd', 1,
434			'Artistic' => 'artistic', 1,
435			'MIT' => 'mit', 1,
436			'proprietary' => 'proprietary', 0,
437			);
438			while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
439			$pattern =~ s{\s+}{\\s+}g;
440			if ( $license_text =~ /\b$pattern\b/i ) {
441			if ( $osi and $license_text =~ /All rights reserved/i ) {
442			print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
443			}
444			$self->license($license);
445			return 1;
446			}
447	dpavlin	34	}
448	dpavlin	52	}
449	dpavlin	34
450	dpavlin	52	warn "Cannot determine license info from $_[0]\n";
451			return 'unknown';
452	dpavlin	34	}
453
454	dpavlin	52	sub bugtracker_from {
455			my $self = shift;
456			my $content = Module::Install::_read($_[0]);
457			my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
458			unless ( @links ) {
459			warn "Cannot determine bugtracker info from $_[0]\n";
460			return 0;
461			}
462			if ( @links > 1 ) {
463			warn "Found more than on rt.cpan.org link in $_[0]\n";
464			return 0;
465			}
466
467			# Set the bugtracker
468			bugtracker( $links[0] );
469			return 1;
470			}
471
472			sub install_script {
473			my $self = shift;
474			my $args = $self->makemaker_args;
475			my $exe = $args->{EXE_FILES} \|\|= [];
476			foreach ( @_ ) {
477			if ( -f $_ ) {
478			push @$exe, $_;
479			} elsif ( -d 'script' and -f "script/$_" ) {
480			push @$exe, "script/$_";
481			} else {
482			die("Cannot find script '$_'");
483			}
484			}
485			}
486
487	dpavlin	34	1;