/[vz-tools]/trunk/inc/Module/Install/Metadata.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/inc/Module/Install/Metadata.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 52 - (show annotations)
Fri Aug 15 09:59:29 2008 UTC (15 years, 7 months ago) by dpavlin
File size: 11226 byte(s)
update Module::Install
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.76';
10 $ISCORE = 1;
11 @ISA = qw{Module::Install::Base};
12 }
13
14 my @scalar_keys = qw{
15 name
16 module_name
17 abstract
18 author
19 version
20 distribution_type
21 tests
22 installdirs
23 };
24
25 my @tuple_keys = qw{
26 configure_requires
27 build_requires
28 requires
29 recommends
30 bundles
31 resources
32 };
33
34 my @resource_keys = qw{
35 homepage
36 bugtracker
37 repository
38 };
39
40 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 }
53
54 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
72 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 }
81
82 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
92 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 # Aliases for build_requires that will have alternative
145 # meanings in some future version of META.yml.
146 sub test_requires { shift->build_requires(@_) }
147 sub install_requires { shift->build_requires(@_) }
148
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 my $self = shift;
157 return $self->{values}{sign} if defined wantarray and ! @_;
158 $self->{values}{sign} = ( @_ ? $_[0] : 1 );
159 return $self;
160 }
161
162 sub dynamic_config {
163 my $self = shift;
164 unless ( @_ ) {
165 warn "You MUST provide an explicit true/false value to dynamic_config\n";
166 return $self;
167 }
168 $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
169 return 1;
170 }
171
172 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 sub all_from {
204 my ( $self, $file ) = @_;
205
206 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
217 # 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
223 # 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
231 return 1;
232 }
233
234 sub provides {
235 my $self = shift;
236 my $provides = ( $self->{values}{provides} ||= {} );
237 %$provides = (%$provides, @_) if @_;
238 return $provides;
239 }
240
241 sub auto_provides {
242 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
253 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 }
261
262 sub feature {
263 my $self = shift;
264 my $name = shift;
265 my $features = ( $self->{values}{features} ||= [] );
266 my $mods;
267
268 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
276 my $count = 0;
277 push @$features, (
278 $name => [
279 map {
280 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
281 } @$mods
282 ]
283 );
284
285 return @$features;
286 }
287
288 sub features {
289 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 }
297
298 sub no_index {
299 my $self = shift;
300 my $type = shift;
301 push @{ $self->{values}{no_index}{$type} }, @_ if $type;
302 return $self->{values}{no_index};
303 }
304
305 sub read {
306 my $self = shift;
307 $self->include_deps( 'YAML::Tiny', 0 );
308
309 require YAML::Tiny;
310 my $data = YAML::Tiny::LoadFile('META.yml');
311
312 # 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 }
325
326 sub write {
327 my $self = shift;
328 return $self unless $self->is_admin;
329 $self->admin->write_meta;
330 return $self;
331 }
332
333 sub version_from {
334 require ExtUtils::MM_Unix;
335 my ( $self, $file ) = @_;
336 $self->version( ExtUtils::MM_Unix->parse_version($file) );
337 }
338
339 sub abstract_from {
340 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 }
349
350 # 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 }
371
372 sub perl_version_from {
373 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 }
391
392 sub author_from {
393 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 }
411
412 sub license_from {
413 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 }
448 }
449
450 warn "Cannot determine license info from $_[0]\n";
451 return 'unknown';
452 }
453
454 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 1;

  ViewVC Help
Powered by ViewVC 1.1.26