root/Encode-DoubleEncodedUTF8/trunk/inc/Module/Install/Metadata.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

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