/[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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 34 by dpavlin, Thu Nov 8 11:35:15 2007 UTC revision 52 by dpavlin, Fri Aug 15 09:59:29 2008 UTC
# Line 6  use Module::Install::Base; Line 6  use Module::Install::Base;
6    
7  use vars qw{$VERSION $ISCORE @ISA};  use vars qw{$VERSION $ISCORE @ISA};
8  BEGIN {  BEGIN {
9          $VERSION = '0.67';          $VERSION = '0.76';
10          $ISCORE  = 1;          $ISCORE  = 1;
11          @ISA     = qw{Module::Install::Base};          @ISA     = qw{Module::Install::Base};
12  }  }
13    
14  my @scalar_keys = qw{  my @scalar_keys = qw{
15      name module_name abstract author version license          name
16      distribution_type perl_version tests installdirs          module_name
17            abstract
18            author
19            version
20            distribution_type
21            tests
22            installdirs
23  };  };
24    
25  my @tuple_keys = qw{  my @tuple_keys = qw{
26      build_requires requires recommends bundles          configure_requires
27            build_requires
28            requires
29            recommends
30            bundles
31            resources
32  };  };
33    
34  sub Meta            { shift        }  my @resource_keys = qw{
35  sub Meta_ScalarKeys { @scalar_keys }          homepage
36  sub Meta_TupleKeys  { @tuple_keys  }          bugtracker
37            repository
38  foreach my $key (@scalar_keys) {  };
39      *$key = sub {  
40          my $self = shift;  sub Meta              { shift          }
41          return $self->{values}{$key} if defined wantarray and !@_;  sub Meta_ScalarKeys   { @scalar_keys   }
42          $self->{values}{$key} = shift;  sub Meta_TupleKeys    { @tuple_keys    }
43          return $self;  sub Meta_ResourceKeys { @resource_keys }
44      };  
45  }  foreach my $key ( @scalar_keys ) {
46            *$key = sub {
47  foreach my $key (@tuple_keys) {                  my $self = shift;
48      *$key = sub {                  return $self->{values}{$key} if defined wantarray and !@_;
49          my $self = shift;                  $self->{values}{$key} = shift;
50          return $self->{values}{$key} unless @_;                  return $self;
51            };
52          my @rv;  }
53          while (@_) {  
54              my $module = shift or last;  foreach my $key ( @resource_keys ) {
55              my $version = shift || 0;          *$key = sub {
56              if ( $module eq 'perl' ) {                  my $self = shift;
57                  $version =~ s{^(\d+)\.(\d+)\.(\d+)}                  unless ( @_ ) {
58                               {$1 + $2/1_000 + $3/1_000_000}e;                          return () unless $self->{values}{resources};
59                  $self->perl_version($version);                          return map  { $_->[1] }
60                  next;                                 grep { $_->[0] eq $key }
61              }                                 @{ $self->{values}{resources} };
62              my $rv = [ $module, $version ];                  }
63              push @rv, $rv;                  return $self->{values}{resources}{$key} unless @_;
64          }                  my $uri = shift or die(
65          push @{ $self->{values}{$key} }, @rv;                          "Did not provide a value to $key()"
66          @rv;                  );
67      };                  $self->resources( $key => $uri );
68                    return 1;
69            };
70  }  }
71    
72  # configure_requires is currently a null-op  sub requires {
73  sub configure_requires { 1 }          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  # Aliases for build_requires that will have alternative
145  # meanings in some future version of META.yml.  # meanings in some future version of META.yml.
146  sub test_requires      { shift->build_requires(@_)  }  sub test_requires      { shift->build_requires(@_) }
147  sub install_requires   { shift->build_requires(@_)  }  sub install_requires   { shift->build_requires(@_) }
148    
149  # Aliases for installdirs options  # Aliases for installdirs options
150  sub install_as_core    { $_[0]->installdirs('perl')   }  sub install_as_core    { $_[0]->installdirs('perl')   }
# Line 71  sub install_as_site    { $_[0]->installd Line 153  sub install_as_site    { $_[0]->installd
153  sub install_as_vendor  { $_[0]->installdirs('vendor') }  sub install_as_vendor  { $_[0]->installdirs('vendor') }
154    
155  sub sign {  sub sign {
156      my $self = shift;          my $self = shift;
157      return $self->{'values'}{'sign'} if defined wantarray and ! @_;          return $self->{values}{sign} if defined wantarray and ! @_;
158      $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );          $self->{values}{sign} = ( @_ ? $_[0] : 1 );
159      return $self;          return $self;
160  }  }
161    
162  sub dynamic_config {  sub dynamic_config {
163          my $self = shift;          my $self = shift;
164          unless ( @_ ) {          unless ( @_ ) {
165                  warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";                  warn "You MUST provide an explicit true/false value to dynamic_config\n";
166                  return $self;                  return $self;
167          }          }
168          $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;          $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
169          return $self;          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 {  sub all_from {
204      my ( $self, $file ) = @_;          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      unless ( defined($file) ) {          # Some methods pull from POD instead of code.
218          my $name = $self->name          # If there is a matching .pod, use that instead
219              or die "all_from called with no args without setting name() first";          my $pod = $file;
220          $file = join('/', 'lib', split(/-/, $name)) . '.pm';          $pod =~ s/\.pm$/.pod/i;
221          $file =~ s{.*/}{} unless -e $file;          $pod = $file unless -e $pod;
222          die "all_from: cannot find $file from $name" unless -e $file;  
223      }          # Pull the different values
224            $self->name_from($file)         unless $self->name;
225      $self->version_from($file)      unless $self->version;          $self->version_from($file)      unless $self->version;
226      $self->perl_version_from($file) unless $self->perl_version;          $self->perl_version_from($file) unless $self->perl_version;
227            $self->author_from($pod)        unless $self->author;
228      # The remaining probes read from POD sections; if the file          $self->license_from($pod)       unless $self->license;
229      # has an accompanying .pod, use that instead          $self->abstract_from($pod)      unless $self->abstract;
230      my $pod = $file;  
231      if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {          return 1;
         $file = $pod;  
     }  
   
     $self->author_from($file)   unless $self->author;  
     $self->license_from($file)  unless $self->license;  
     $self->abstract_from($file) unless $self->abstract;  
232  }  }
233    
234  sub provides {  sub provides {
235      my $self     = shift;          my $self     = shift;
236      my $provides = ( $self->{values}{provides} ||= {} );          my $provides = ( $self->{values}{provides} ||= {} );
237      %$provides = (%$provides, @_) if @_;          %$provides = (%$provides, @_) if @_;
238      return $provides;          return $provides;
239  }  }
240    
241  sub auto_provides {  sub auto_provides {
242      my $self = shift;          my $self = shift;
243      return $self unless $self->is_admin;          return $self unless $self->is_admin;
244            unless (-e 'MANIFEST') {
245      unless (-e 'MANIFEST') {                  warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
246          warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";                  return $self;
247          return $self;          }
248      }          # Avoid spurious warnings as we are not checking manifest here.
249            local $SIG{__WARN__} = sub {1};
250      # Avoid spurious warnings as we are not checking manifest here.          require ExtUtils::Manifest;
251            local *ExtUtils::Manifest::manicheck = sub { return };
252      local $SIG{__WARN__} = sub {1};  
253      require ExtUtils::Manifest;          require Module::Build;
254      local *ExtUtils::Manifest::manicheck = sub { return };          my $build = Module::Build->new(
255                    dist_name    => $self->name,
256      require Module::Build;                  dist_version => $self->version,
257      my $build = Module::Build->new(                  license      => $self->license,
258          dist_name    => $self->name,          );
259          dist_version => $self->version,          $self->provides( %{ $build->find_dist_packages || {} } );
         license      => $self->license,  
     );  
     $self->provides(%{ $build->find_dist_packages || {} });  
260  }  }
261    
262  sub feature {  sub feature {
263      my $self     = shift;          my $self     = shift;
264      my $name     = shift;          my $name     = shift;
265      my $features = ( $self->{values}{features} ||= [] );          my $features = ( $self->{values}{features} ||= [] );
266            my $mods;
267      my $mods;  
268            if ( @_ == 1 and ref( $_[0] ) ) {
269      if ( @_ == 1 and ref( $_[0] ) ) {                  # The user used ->feature like ->features by passing in the second
270          # The user used ->feature like ->features by passing in the second                  # argument as a reference.  Accomodate for that.
271          # argument as a reference.  Accomodate for that.                  $mods = $_[0];
272          $mods = $_[0];          } else {
273      } else {                  $mods = \@_;
274          $mods = \@_;          }
275      }  
276            my $count = 0;
277      my $count = 0;          push @$features, (
278      push @$features, (                  $name => [
279          $name => [                          map {
280              map {                                  ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
281                  ref($_) ? ( ref($_) eq 'HASH' ) ? %$_                          } @$mods
282                                                  : @$_                  ]
283                          : $_          );
             } @$mods  
         ]  
     );  
284    
285      return @$features;          return @$features;
286  }  }
287    
288  sub features {  sub features {
289      my $self = shift;          my $self = shift;
290      while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {          while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
291          $self->feature( $name, @$mods );                  $self->feature( $name, @$mods );
292      }          }
293      return $self->{values}->{features}          return $self->{values}{features}
294          ? @{ $self->{values}->{features} }                  ? @{ $self->{values}{features} }
295          : ();                  : ();
296  }  }
297    
298  sub no_index {  sub no_index {
299      my $self = shift;          my $self = shift;
300      my $type = shift;          my $type = shift;
301      push @{ $self->{values}{no_index}{$type} }, @_ if $type;          push @{ $self->{values}{no_index}{$type} }, @_ if $type;
302      return $self->{values}{no_index};          return $self->{values}{no_index};
303  }  }
304    
305  sub read {  sub read {
306      my $self = shift;          my $self = shift;
307      $self->include_deps( 'YAML', 0 );          $self->include_deps( 'YAML::Tiny', 0 );
308    
309      require YAML;          require YAML::Tiny;
310      my $data = YAML::LoadFile('META.yml');          my $data = YAML::Tiny::LoadFile('META.yml');
311    
312      # Call methods explicitly in case user has already set some values.          # Call methods explicitly in case user has already set some values.
313      while ( my ( $key, $value ) = each %$data ) {          while ( my ( $key, $value ) = each %$data ) {
314          next unless $self->can($key);                  next unless $self->can($key);
315          if ( ref $value eq 'HASH' ) {                  if ( ref $value eq 'HASH' ) {
316              while ( my ( $module, $version ) = each %$value ) {                          while ( my ( $module, $version ) = each %$value ) {
317                  $self->can($key)->($self, $module => $version );                                  $self->can($key)->($self, $module => $version );
318              }                          }
319          }                  } else {
320          else {                          $self->can($key)->($self, $value);
321              $self->can($key)->($self, $value);                  }
322          }          }
323      }          return $self;
     return $self;  
324  }  }
325    
326  sub write {  sub write {
327      my $self = shift;          my $self = shift;
328      return $self unless $self->is_admin;          return $self unless $self->is_admin;
329      $self->admin->write_meta;          $self->admin->write_meta;
330      return $self;          return $self;
331  }  }
332    
333  sub version_from {  sub version_from {
334      my ( $self, $file ) = @_;          require ExtUtils::MM_Unix;
335      require ExtUtils::MM_Unix;          my ( $self, $file ) = @_;
336      $self->version( ExtUtils::MM_Unix->parse_version($file) );          $self->version( ExtUtils::MM_Unix->parse_version($file) );
337  }  }
338    
339  sub abstract_from {  sub abstract_from {
340      my ( $self, $file ) = @_;          require ExtUtils::MM_Unix;
341      require ExtUtils::MM_Unix;          my ( $self, $file ) = @_;
342      $self->abstract(          $self->abstract(
343          bless(                  bless(
344              { DISTNAME => $self->name },                          { DISTNAME => $self->name },
345              'ExtUtils::MM_Unix'                          'ExtUtils::MM_Unix'
346          )->parse_abstract($file)                  )->parse_abstract($file)
347       );           );
348  }  }
349    
350  sub _slurp {  # Add both distribution and module name
351      my ( $self, $file ) = @_;  sub name_from {
352            my ($self, $file) = @_;
353      local *FH;          if (
354      open FH, "< $file" or die "Cannot open $file.pod: $!";                  Module::Install::_read($file) =~ m/
355      do { local $/; <FH> };                  ^ \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 {  sub perl_version_from {
373      my ( $self, $file ) = @_;          my $self = shift;
374            if (
375      if (                  Module::Install::_read($_[0]) =~ m/
376          $self->_slurp($file) =~ m/                  ^
377          ^                  (?:use|require) \s*
378          use \s*                  v?
379          v?                  ([\d_\.]+)
380          ([\d_\.]+)                  \s* ;
381          \s* ;                  /ixms
382      /ixms          ) {
383        )                  my $perl_version = $1;
384      {                  $perl_version =~ s{_}{}g;
385          my $v = $1;                  $self->perl_version($perl_version);
386          $v =~ s{_}{}g;          } else {
387          $self->perl_version($1);                  warn "Cannot determine perl version info from $_[0]\n";
388      }                  return;
389      else {          }
         warn "Cannot determine perl version info from $file\n";  
         return;  
     }  
390  }  }
391    
392  sub author_from {  sub author_from {
393      my ( $self, $file ) = @_;          my $self    = shift;
394      my $content = $self->_slurp($file);          my $content = Module::Install::_read($_[0]);
395      if ($content =~ m/          if ($content =~ m/
396          =head \d \s+ (?:authors?)\b \s*                  =head \d \s+ (?:authors?)\b \s*
397          ([^\n]*)                  ([^\n]*)
398          |                  |
399          =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*                  =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
400          .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*                  .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
401          ([^\n]*)                  ([^\n]*)
402      /ixms) {          /ixms) {
403          my $author = $1 || $2;                  my $author = $1 || $2;
404          $author =~ s{E<lt>}{<}g;                  $author =~ s{E<lt>}{<}g;
405          $author =~ s{E<gt>}{>}g;                  $author =~ s{E<gt>}{>}g;
406          $self->author($author);                  $self->author($author);
407      }          } else {
408      else {                  warn "Cannot determine author info from $_[0]\n";
409          warn "Cannot determine author info from $file\n";          }
     }  
410  }  }
411    
412  sub license_from {  sub license_from {
413      my ( $self, $file ) = @_;          my $self = shift;
414            if (
415      if (                  Module::Install::_read($_[0]) =~ m/
416          $self->_slurp($file) =~ m/                  (
417          (                          =head \d \s+
418              =head \d \s+                          (?:licen[cs]e|licensing|copyright|legal)\b
419              (?:licen[cs]e|licensing|copyright|legal)\b                          .*?
420              .*?                  )
421          )                  (=head\\d.*|=cut.*|)
422          (=head\\d.*|=cut.*|)                  \z
423          \z          /ixms ) {
424      /ixms                  my $license_text = $1;
425        )                  my @phrases      = (
426      {                          'under the same (?:terms|license) as perl itself' => 'perl',        1,
427          my $license_text = $1;                          'GNU public license'                              => 'gpl',         1,
428          my @phrases      = (                          'GNU lesser public license'                       => 'lgpl',        1,
429              'under the same (?:terms|license) as perl itself' => 'perl',        1,                          'BSD license'                                     => 'bsd',         1,
430              'GNU public license'                              => 'gpl',         1,                          'Artistic license'                                => 'artistic',    1,
431              'GNU lesser public license'                       => 'gpl',         1,                          'GPL'                                             => 'gpl',         1,
432              'BSD license'                                     => 'bsd',         1,                          'LGPL'                                            => 'lgpl',        1,
433              'Artistic license'                                => 'artistic',    1,                          'BSD'                                             => 'bsd',         1,
434              'GPL'                                             => 'gpl',         1,                          'Artistic'                                        => 'artistic',    1,
435              'LGPL'                                            => 'lgpl',        1,                          'MIT'                                             => 'mit',         1,
436              'BSD'                                             => 'bsd',         1,                          'proprietary'                                     => 'proprietary', 0,
437              'Artistic'                                        => 'artistic',    1,                  );
438              'MIT'                                             => 'mit',         1,                  while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
439              'proprietary'                                     => 'proprietary', 0,                          $pattern =~ s{\s+}{\\s+}g;
440          );                          if ( $license_text =~ /\b$pattern\b/i ) {
441          while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {                                  if ( $osi and $license_text =~ /All rights reserved/i ) {
442              $pattern =~ s{\s+}{\\s+}g;                                          print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
443              if ( $license_text =~ /\b$pattern\b/i ) {                                  }
444                  if ( $osi and $license_text =~ /All rights reserved/i ) {                                  $self->license($license);
445                          warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";                                  return 1;
446                            }
447                  }                  }
448                  $self->license($license);          }
                 return 1;  
             }  
         }  
     }  
449    
450      warn "Cannot determine license info from $file\n";          warn "Cannot determine license info from $_[0]\n";
451      return 'unknown';          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;  1;
Legend:
Removed from v.34  
changed lines
  Added in v.52
  ViewVC Help
Powered by ViewVC 1.1.26