/[cwmp]/google/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 /google/trunk/inc/Module/Install/Metadata.pm

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

revision 241 by dpavlin, Mon Nov 12 15:51:25 2007 UTC revision 242 by dpavlin, Mon Jul 14 16:35:25 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.68';          $VERSION = '0.75';
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            license
21            distribution_type
22            perl_version
23            tests
24            installdirs
25  };  };
26    
27  my @tuple_keys = qw{  my @tuple_keys = qw{
28      build_requires requires recommends bundles          configure_requires
29            build_requires
30            requires
31            recommends
32            bundles
33            resources
34  };  };
35    
36  sub Meta            { shift        }  sub Meta            { shift        }
# Line 25  sub Meta_ScalarKeys { @scalar_keys } Line 38  sub Meta_ScalarKeys { @scalar_keys }
38  sub Meta_TupleKeys  { @tuple_keys  }  sub Meta_TupleKeys  { @tuple_keys  }
39    
40  foreach my $key (@scalar_keys) {  foreach my $key (@scalar_keys) {
41      *$key = sub {          *$key = sub {
42          my $self = shift;                  my $self = shift;
43          return $self->{values}{$key} if defined wantarray and !@_;                  return $self->{values}{$key} if defined wantarray and !@_;
44          $self->{values}{$key} = shift;                  $self->{values}{$key} = shift;
45          return $self;                  return $self;
46      };          };
47  }  }
48    
49  foreach my $key (@tuple_keys) {  sub requires {
50      *$key = sub {          my $self = shift;
51          my $self = shift;          while ( @_ ) {
52          return $self->{values}{$key} unless @_;                  my $module  = shift or last;
53                    my $version = shift || 0;
54          my @rv;                  push @{ $self->{values}->{requires} }, [ $module, $version ];
55          while (@_) {          }
56              my $module = shift or last;          $self->{values}{requires};
57              my $version = shift || 0;  }
58              if ( $module eq 'perl' ) {  
59                  $version =~ s{^(\d+)\.(\d+)\.(\d+)}  sub build_requires {
60                               {$1 + $2/1_000 + $3/1_000_000}e;          my $self = shift;
61                  $self->perl_version($version);          while ( @_ ) {
62                  next;                  my $module  = shift or last;
63              }                  my $version = shift || 0;
64              my $rv = [ $module, $version ];                  push @{ $self->{values}->{build_requires} }, [ $module, $version ];
65              push @rv, $rv;          }
66          }          $self->{values}{build_requires};
67          push @{ $self->{values}{$key} }, @rv;  }
68          @rv;  
69      };  sub configure_requires {
70            my $self = shift;
71            while ( @_ ) {
72                    my $module  = shift or last;
73                    my $version = shift || 0;
74                    push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
75            }
76            $self->{values}->{configure_requires};
77  }  }
78    
79  # configure_requires is currently a null-op  sub recommends {
80  sub configure_requires { 1 }          my $self = shift;
81            while ( @_ ) {
82                    my $module  = shift or last;
83                    my $version = shift || 0;
84                    push @{ $self->{values}->{recommends} }, [ $module, $version ];
85            }
86            $self->{values}->{recommends};
87    }
88    
89    sub bundles {
90            my $self = shift;
91            while ( @_ ) {
92                    my $module  = shift or last;
93                    my $version = shift || 0;
94                    push @{ $self->{values}->{bundles} }, [ $module, $version ];
95            }
96            $self->{values}->{bundles};
97    }
98    
99    # Resource handling
100    sub resources {
101            my $self = shift;
102            while ( @_ ) {
103                    my $resource = shift or last;
104                    my $value    = shift or next;
105                    push @{ $self->{values}->{resources} }, [ $resource, $value ];
106            }
107            $self->{values}->{resources};
108    }
109    
110    sub repository {
111            my $self = shift;
112            $self->resources( repository => shift );
113            return 1;
114    }
115    
116  # Aliases for build_requires that will have alternative  # Aliases for build_requires that will have alternative
117  # meanings in some future version of META.yml.  # meanings in some future version of META.yml.
118  sub test_requires      { shift->build_requires(@_)  }  sub test_requires      { shift->build_requires(@_) }
119  sub install_requires   { shift->build_requires(@_)  }  sub install_requires   { shift->build_requires(@_) }
120    
121  # Aliases for installdirs options  # Aliases for installdirs options
122  sub install_as_core    { $_[0]->installdirs('perl')   }  sub install_as_core    { $_[0]->installdirs('perl')   }
# Line 71  sub install_as_site    { $_[0]->installd Line 125  sub install_as_site    { $_[0]->installd
125  sub install_as_vendor  { $_[0]->installdirs('vendor') }  sub install_as_vendor  { $_[0]->installdirs('vendor') }
126    
127  sub sign {  sub sign {
128      my $self = shift;          my $self = shift;
129      return $self->{'values'}{'sign'} if defined wantarray and ! @_;          return $self->{'values'}{'sign'} if defined wantarray and ! @_;
130      $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );          $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
131      return $self;          return $self;
132  }  }
133    
134  sub dynamic_config {  sub dynamic_config {
# Line 83  sub dynamic_config { Line 137  sub dynamic_config {
137                  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, skipping\n";
138                  return $self;                  return $self;
139          }          }
140          $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;          $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
141          return $self;          return $self;
142  }  }
143    
144  sub all_from {  sub all_from {
145      my ( $self, $file ) = @_;          my ( $self, $file ) = @_;
146    
147            unless ( defined($file) ) {
148                    my $name = $self->name
149                            or die "all_from called with no args without setting name() first";
150                    $file = join('/', 'lib', split(/-/, $name)) . '.pm';
151                    $file =~ s{.*/}{} unless -e $file;
152                    die "all_from: cannot find $file from $name" unless -e $file;
153            }
154    
155      unless ( defined($file) ) {          # Some methods pull from POD instead of code.
156          my $name = $self->name          # If there is a matching .pod, use that instead
157              or die "all_from called with no args without setting name() first";          my $pod = $file;
158          $file = join('/', 'lib', split(/-/, $name)) . '.pm';          $pod =~ s/\.pm$/.pod/i;
159          $file =~ s{.*/}{} unless -e $file;          $pod = $file unless -e $pod;
160          die "all_from: cannot find $file from $name" unless -e $file;  
161      }          # Pull the different values
162            $self->name_from($file)         unless $self->name;
163      $self->version_from($file)      unless $self->version;          $self->version_from($file)      unless $self->version;
164      $self->perl_version_from($file) unless $self->perl_version;          $self->perl_version_from($file) unless $self->perl_version;
165            $self->author_from($pod)        unless $self->author;
166      # The remaining probes read from POD sections; if the file          $self->license_from($pod)       unless $self->license;
167      # has an accompanying .pod, use that instead          $self->abstract_from($pod)      unless $self->abstract;
168      my $pod = $file;  
169      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;  
170  }  }
171    
172  sub provides {  sub provides {
173      my $self     = shift;          my $self     = shift;
174      my $provides = ( $self->{values}{provides} ||= {} );          my $provides = ( $self->{values}{provides} ||= {} );
175      %$provides = (%$provides, @_) if @_;          %$provides = (%$provides, @_) if @_;
176      return $provides;          return $provides;
177  }  }
178    
179  sub auto_provides {  sub auto_provides {
180      my $self = shift;          my $self = shift;
181      return $self unless $self->is_admin;          return $self unless $self->is_admin;
182            unless (-e 'MANIFEST') {
183      unless (-e 'MANIFEST') {                  warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
184          warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";                  return $self;
185          return $self;          }
186      }          # Avoid spurious warnings as we are not checking manifest here.
187            local $SIG{__WARN__} = sub {1};
188      # Avoid spurious warnings as we are not checking manifest here.          require ExtUtils::Manifest;
189            local *ExtUtils::Manifest::manicheck = sub { return };
190      local $SIG{__WARN__} = sub {1};  
191      require ExtUtils::Manifest;          require Module::Build;
192      local *ExtUtils::Manifest::manicheck = sub { return };          my $build = Module::Build->new(
193                    dist_name    => $self->name,
194      require Module::Build;                  dist_version => $self->version,
195      my $build = Module::Build->new(                  license      => $self->license,
196          dist_name    => $self->name,          );
197          dist_version => $self->version,          $self->provides( %{ $build->find_dist_packages || {} } );
         license      => $self->license,  
     );  
     $self->provides(%{ $build->find_dist_packages || {} });  
198  }  }
199    
200  sub feature {  sub feature {
201      my $self     = shift;          my $self     = shift;
202      my $name     = shift;          my $name     = shift;
203      my $features = ( $self->{values}{features} ||= [] );          my $features = ( $self->{values}{features} ||= [] );
204            my $mods;
205      my $mods;  
206            if ( @_ == 1 and ref( $_[0] ) ) {
207      if ( @_ == 1 and ref( $_[0] ) ) {                  # The user used ->feature like ->features by passing in the second
208          # The user used ->feature like ->features by passing in the second                  # argument as a reference.  Accomodate for that.
209          # argument as a reference.  Accomodate for that.                  $mods = $_[0];
210          $mods = $_[0];          } else {
211      } else {                  $mods = \@_;
212          $mods = \@_;          }
     }  
   
     my $count = 0;  
     push @$features, (  
         $name => [  
             map {  
                 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_  
                                                 : @$_  
                         : $_  
             } @$mods  
         ]  
     );  
213    
214      return @$features;          my $count = 0;
215            push @$features, (
216                    $name => [
217                            map {
218                                    ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
219                            } @$mods
220                    ]
221            );
222    
223            return @$features;
224  }  }
225    
226  sub features {  sub features {
227      my $self = shift;          my $self = shift;
228      while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {          while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
229          $self->feature( $name, @$mods );                  $self->feature( $name, @$mods );
230      }          }
231      return $self->{values}->{features}          return $self->{values}->{features}
232          ? @{ $self->{values}->{features} }                  ? @{ $self->{values}->{features} }
233          : ();                  : ();
234  }  }
235    
236  sub no_index {  sub no_index {
237      my $self = shift;          my $self = shift;
238      my $type = shift;          my $type = shift;
239      push @{ $self->{values}{no_index}{$type} }, @_ if $type;          push @{ $self->{values}{no_index}{$type} }, @_ if $type;
240      return $self->{values}{no_index};          return $self->{values}{no_index};
241  }  }
242    
243  sub read {  sub read {
244      my $self = shift;          my $self = shift;
245      $self->include_deps( 'YAML', 0 );          $self->include_deps( 'YAML::Tiny', 0 );
246    
247      require YAML;          require YAML::Tiny;
248      my $data = YAML::LoadFile('META.yml');          my $data = YAML::Tiny::LoadFile('META.yml');
249    
250      # Call methods explicitly in case user has already set some values.          # Call methods explicitly in case user has already set some values.
251      while ( my ( $key, $value ) = each %$data ) {          while ( my ( $key, $value ) = each %$data ) {
252          next unless $self->can($key);                  next unless $self->can($key);
253          if ( ref $value eq 'HASH' ) {                  if ( ref $value eq 'HASH' ) {
254              while ( my ( $module, $version ) = each %$value ) {                          while ( my ( $module, $version ) = each %$value ) {
255                  $self->can($key)->($self, $module => $version );                                  $self->can($key)->($self, $module => $version );
256              }                          }
257          }                  } else {
258          else {                          $self->can($key)->($self, $value);
259              $self->can($key)->($self, $value);                  }
260          }          }
261      }          return $self;
     return $self;  
262  }  }
263    
264  sub write {  sub write {
265      my $self = shift;          my $self = shift;
266      return $self unless $self->is_admin;          return $self unless $self->is_admin;
267      $self->admin->write_meta;          $self->admin->write_meta;
268      return $self;          return $self;
269  }  }
270    
271  sub version_from {  sub version_from {
272      my ( $self, $file ) = @_;          require ExtUtils::MM_Unix;
273      require ExtUtils::MM_Unix;          my ( $self, $file ) = @_;
274      $self->version( ExtUtils::MM_Unix->parse_version($file) );          $self->version( ExtUtils::MM_Unix->parse_version($file) );
275  }  }
276    
277  sub abstract_from {  sub abstract_from {
278      my ( $self, $file ) = @_;          require ExtUtils::MM_Unix;
279      require ExtUtils::MM_Unix;          my ( $self, $file ) = @_;
280      $self->abstract(          $self->abstract(
281          bless(                  bless(
282              { DISTNAME => $self->name },                          { DISTNAME => $self->name },
283              'ExtUtils::MM_Unix'                          'ExtUtils::MM_Unix'
284          )->parse_abstract($file)                  )->parse_abstract($file)
285       );           );
286  }  }
287    
288  sub _slurp {  # Add both distribution and module name
289      my ( $self, $file ) = @_;  sub name_from {
290            my ($self, $file) = @_;
291      local *FH;          if (
292      open FH, "< $file" or die "Cannot open $file.pod: $!";                  Module::Install::_read($file) =~ m/
293      do { local $/; <FH> };                  ^ \s*
294                    package \s*
295                    ([\w:]+)
296                    \s* ;
297                    /ixms
298            ) {
299                    my ($name, $module_name) = ($1, $1);
300                    $name =~ s{::}{-}g;
301                    $self->name($name);
302                    unless ( $self->module_name ) {
303                            $self->module_name($module_name);
304                    }
305            } else {
306                    die "Cannot determine name from $file\n";
307            }
308  }  }
309    
310  sub perl_version_from {  sub perl_version_from {
311      my ( $self, $file ) = @_;          my $self = shift;
312            if (
313      if (                  Module::Install::_read($_[0]) =~ m/
314          $self->_slurp($file) =~ m/                  ^
315          ^                  (?:use|require) \s*
316          use \s*                  v?
317          v?                  ([\d_\.]+)
318          ([\d_\.]+)                  \s* ;
319          \s* ;                  /ixms
320      /ixms          ) {
321        )                  my $perl_version = $1;
322      {                  $perl_version =~ s{_}{}g;
323          my $v = $1;                  $self->perl_version($perl_version);
324          $v =~ s{_}{}g;          } else {
325          $self->perl_version($1);                  warn "Cannot determine perl version info from $_[0]\n";
326      }                  return;
327      else {          }
         warn "Cannot determine perl version info from $file\n";  
         return;  
     }  
328  }  }
329    
330  sub author_from {  sub author_from {
331      my ( $self, $file ) = @_;          my $self    = shift;
332      my $content = $self->_slurp($file);          my $content = Module::Install::_read($_[0]);
333      if ($content =~ m/          if ($content =~ m/
334          =head \d \s+ (?:authors?)\b \s*                  =head \d \s+ (?:authors?)\b \s*
335          ([^\n]*)                  ([^\n]*)
336          |                  |
337          =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*                  =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
338          .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*                  .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
339          ([^\n]*)                  ([^\n]*)
340      /ixms) {          /ixms) {
341          my $author = $1 || $2;                  my $author = $1 || $2;
342          $author =~ s{E<lt>}{<}g;                  $author =~ s{E<lt>}{<}g;
343          $author =~ s{E<gt>}{>}g;                  $author =~ s{E<gt>}{>}g;
344          $self->author($author);                  $self->author($author);
345      }          } else {
346      else {                  warn "Cannot determine author info from $_[0]\n";
347          warn "Cannot determine author info from $file\n";          }
     }  
348  }  }
349    
350  sub license_from {  sub license_from {
351      my ( $self, $file ) = @_;          my $self = shift;
352            if (
353      if (                  Module::Install::_read($_[0]) =~ m/
354          $self->_slurp($file) =~ m/                  (
355          (                          =head \d \s+
356              =head \d \s+                          (?:licen[cs]e|licensing|copyright|legal)\b
357              (?:licen[cs]e|licensing|copyright|legal)\b                          .*?
358              .*?                  )
359          )                  (=head\\d.*|=cut.*|)
360          (=head\\d.*|=cut.*|)                  \z
361          \z          /ixms ) {
362      /ixms                  my $license_text = $1;
363        )                  my @phrases      = (
364      {                          'under the same (?:terms|license) as perl itself' => 'perl',        1,
365          my $license_text = $1;                          'GNU public license'                              => 'gpl',         1,
366          my @phrases      = (                          'GNU lesser public license'                       => 'lgpl',        1,
367              'under the same (?:terms|license) as perl itself' => 'perl',        1,                          'BSD license'                                     => 'bsd',         1,
368              'GNU public license'                              => 'gpl',         1,                          'Artistic license'                                => 'artistic',    1,
369              'GNU lesser public license'                       => 'gpl',         1,                          'GPL'                                             => 'gpl',         1,
370              'BSD license'                                     => 'bsd',         1,                          'LGPL'                                            => 'lgpl',        1,
371              'Artistic license'                                => 'artistic',    1,                          'BSD'                                             => 'bsd',         1,
372              'GPL'                                             => 'gpl',         1,                          'Artistic'                                        => 'artistic',    1,
373              'LGPL'                                            => 'lgpl',        1,                          'MIT'                                             => 'mit',         1,
374              'BSD'                                             => 'bsd',         1,                          'proprietary'                                     => 'proprietary', 0,
375              'Artistic'                                        => 'artistic',    1,                  );
376              'MIT'                                             => 'mit',         1,                  while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
377              'proprietary'                                     => 'proprietary', 0,                          $pattern =~ s{\s+}{\\s+}g;
378          );                          if ( $license_text =~ /\b$pattern\b/i ) {
379          while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {                                  if ( $osi and $license_text =~ /All rights reserved/i ) {
380              $pattern =~ s{\s+}{\\s+}g;                                          print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
381              if ( $license_text =~ /\b$pattern\b/i ) {                                  }
382                  if ( $osi and $license_text =~ /All rights reserved/i ) {                                  $self->license($license);
383                          warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";                                  return 1;
384                            }
385                  }                  }
386                  $self->license($license);          }
387                  return 1;  
388              }          warn "Cannot determine license info from $_[0]\n";
389          }          return 'unknown';
390      }  }
391    
392      warn "Cannot determine license info from $file\n";  sub install_script {
393      return 'unknown';          my $self = shift;
394            my $args = $self->makemaker_args;
395            my $exe  = $args->{EXE_FILES} ||= [];
396            foreach ( @_ ) {
397                    if ( -f $_ ) {
398                            push @$exe, $_;
399                    } elsif ( -d 'script' and -f "script/$_" ) {
400                            push @$exe, "script/$_";
401                    } else {
402                            die "Cannot find script '$_'";
403                    }
404            }
405  }  }
406    
407  1;  1;
Legend:
Removed from v.241  
changed lines
  Added in v.242
  ViewVC Help
Powered by ViewVC 1.1.26