source: perl/modules/Jabber/inc/Module/Install/Metadata.pm @ 300b470

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