git.maemo.org Git - pkg-perl/blob - deb-src/libspiffy-perl/libspiffy-perl-0.30/inc/Module/Install/Metadata.pm

   1 #line 1 "inc/Module/Install/Metadata.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Metadata.pm"
   2 package Module::Install::Metadata;
   3
   4 use strict 'vars';
   5 use Module::Install::Base;
   6
   7 use vars qw($VERSION @ISA);
   8 BEGIN {
   9     $VERSION = '0.06';
  10     @ISA     = 'Module::Install::Base';
  11 }
  12
  13 my @scalar_keys = qw{
  14     name module_name abstract author version license
  15     distribution_type perl_version tests
  16 };
  17
  18 my @tuple_keys = qw{
  19     build_requires requires recommends bundles
  20 };
  21
  22 sub Meta            { shift        }
  23 sub Meta_ScalarKeys { @scalar_keys }
  24 sub Meta_TupleKeys  { @tuple_keys  }
  25
  26 foreach my $key (@scalar_keys) {
  27     *$key = sub {
  28         my $self = shift;
  29         return $self->{values}{$key} if defined wantarray and !@_;
  30         $self->{values}{$key} = shift;
  31         return $self;
  32     };
  33 }
  34
  35 foreach my $key (@tuple_keys) {
  36     *$key = sub {
  37         my $self = shift;
  38         return $self->{values}{$key} unless @_;
  39
  40         my @rv;
  41         while (@_) {
  42             my $module = shift or last;
  43             my $version = shift || 0;
  44             if ( $module eq 'perl' ) {
  45                 $version =~ s{^(\d+)\.(\d+)\.(\d+)}
  46                              {$1 + $2/1_000 + $3/1_000_000}e;
  47                 $self->perl_version($version);
  48                 next;
  49             }
  50             my $rv = [ $module, $version ];
  51             push @rv, $rv;
  52         }
  53         push @{ $self->{values}{$key} }, @rv;
  54         @rv;
  55     };
  56 }
  57
  58 sub sign {
  59     my $self = shift;
  60     return $self->{'values'}{'sign'} if defined wantarray and !@_;
  61     $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
  62     return $self;
  63 }
  64
  65 sub all_from {
  66     my ( $self, $file ) = @_;
  67
  68     unless ( defined($file) ) {
  69         my $name = $self->name
  70             or die "all_from called with no args without setting name() first";
  71         $file = join('/', 'lib', split(/-/, $name)) . '.pm';
  72         $file =~ s{.*/}{} unless -e $file;
  73         die "all_from: cannot find $file from $name" unless -e $file;
  74     }
  75
  76     $self->version_from($file)      unless $self->version;
  77     $self->perl_version_from($file) unless $self->perl_version;
  78
  79     # The remaining probes read from POD sections; if the file
  80     # has an accompanying .pod, use that instead
  81     my $pod = $file;
  82     if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
  83         $file = $pod;
  84     }
  85
  86     $self->author_from($file)   unless $self->author;
  87     $self->license_from($file)  unless $self->license;
  88     $self->abstract_from($file) unless $self->abstract;
  89 }
  90
  91 sub provides {
  92     my $self     = shift;
  93     my $provides = ( $self->{values}{provides} ||= {} );
  94     %$provides = (%$provides, @_) if @_;
  95     return $provides;
  96 }
  97
  98 sub auto_provides {
  99     my $self = shift;
 100     return $self unless $self->is_admin;
 101
 102     unless (-e 'MANIFEST') {
 103         warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
 104         return $self;
 105     }
 106
 107     # Avoid spurious warnings as we are not checking manifest here.
 108
 109     local $SIG{__WARN__} = sub {1};
 110     require ExtUtils::Manifest;
 111     local *ExtUtils::Manifest::manicheck = sub { return };
 112
 113     require Module::Build;
 114     my $build = Module::Build->new(
 115         dist_name    => $self->{name},
 116         dist_version => $self->{version},
 117         license      => $self->{license},
 118     );
 119     $self->provides(%{ $build->find_dist_packages || {} });
 120 }
 121
 122 sub feature {
 123     my $self     = shift;
 124     my $name     = shift;
 125     my $features = ( $self->{values}{features} ||= [] );
 126
 127     my $mods;
 128
 129     if ( @_ == 1 and ref( $_[0] ) ) {
 130         # The user used ->feature like ->features by passing in the second
 131         # argument as a reference.  Accomodate for that.
 132         $mods = $_[0];
 133     }
 134     else {
 135         $mods = \@_;
 136     }
 137
 138     my $count = 0;
 139     push @$features, (
 140         $name => [
 141             map {
 142                 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
 143                                                 : @$_
 144                         : $_
 145             } @$mods
 146         ]
 147     );
 148
 149     return @$features;
 150 }
 151
 152 sub features {
 153     my $self = shift;
 154     while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
 155         $self->feature( $name, @$mods );
 156     }
 157     return @{ $self->{values}{features} };
 158 }
 159
 160 sub no_index {
 161     my $self = shift;
 162     my $type = shift;
 163     push @{ $self->{values}{no_index}{$type} }, @_ if $type;
 164     return $self->{values}{no_index};
 165 }
 166
 167 sub read {
 168     my $self = shift;
 169     $self->include_deps( 'YAML', 0 );
 170
 171     require YAML;
 172     my $data = YAML::LoadFile('META.yml');
 173
 174     # Call methods explicitly in case user has already set some values.
 175     while ( my ( $key, $value ) = each %$data ) {
 176         next unless $self->can($key);
 177         if ( ref $value eq 'HASH' ) {
 178             while ( my ( $module, $version ) = each %$value ) {
 179                 $self->can($key)->($self, $module => $version );
 180             }
 181         }
 182         else {
 183             $self->can($key)->($self, $value);
 184         }
 185     }
 186     return $self;
 187 }
 188
 189 sub write {
 190     my $self = shift;
 191     return $self unless $self->is_admin;
 192     $self->admin->write_meta;
 193     return $self;
 194 }
 195
 196 sub version_from {
 197     my ( $self, $file ) = @_;
 198     require ExtUtils::MM_Unix;
 199     $self->version( ExtUtils::MM_Unix->parse_version($file) );
 200 }
 201
 202 sub abstract_from {
 203     my ( $self, $file ) = @_;
 204     require ExtUtils::MM_Unix;
 205     $self->abstract(
 206         bless(
 207             { DISTNAME => $self->name },
 208             'ExtUtils::MM_Unix'
 209         )->parse_abstract($file)
 210      );
 211 }
 212
 213 sub _slurp {
 214     my ( $self, $file ) = @_;
 215
 216     local *FH;
 217     open FH, "< $file" or die "Cannot open $file.pod: $!";
 218     do { local $/; <FH> };
 219 }
 220
 221 sub perl_version_from {
 222     my ( $self, $file ) = @_;
 223
 224     if (
 225         $self->_slurp($file) =~ m/
 226         ^
 227         use \s*
 228         v?
 229         ([\d\.]+)
 230         \s* ;
 231     /ixms
 232       )
 233     {
 234         $self->perl_version($1);
 235     }
 236     else {
 237         warn "Cannot determine perl version info from $file\n";
 238         return;
 239     }
 240 }
 241
 242 sub author_from {
 243     my ( $self, $file ) = @_;
 244     my $content = $self->_slurp($file);
 245     if ($content =~ m/
 246         =head \d \s+ (?:authors?)\b \s*
 247         ([^\n]*)
 248         |
 249         =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
 250         .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
 251         ([^\n]*)
 252     /ixms) {
 253         my $author = $1 || $2;
 254         $author =~ s{E<lt>}{<}g;
 255         $author =~ s{E<gt>}{>}g;
 256         $self->author($author);
 257     }
 258     else {
 259         warn "Cannot determine author info from $file\n";
 260     }
 261 }
 262
 263 sub license_from {
 264     my ( $self, $file ) = @_;
 265
 266     if (
 267         $self->_slurp($file) =~ m/
 268         =head \d \s+
 269         (?:licen[cs]e|licensing|copyright|legal)\b
 270         (.*?)
 271         (=head\\d.*|=cut.*|)
 272         \z
 273     /ixms
 274       )
 275     {
 276         my $license_text = $1;
 277         my @phrases      = (
 278             'under the same (?:terms|license) as perl itself' => 'perl',
 279             'GNU public license'                              => 'gpl',
 280             'GNU lesser public license'                       => 'gpl',
 281             'BSD license'                                     => 'bsd',
 282             'Artistic license'                                => 'artistic',
 283             'GPL'                                             => 'gpl',
 284             'LGPL'                                            => 'lgpl',
 285             'BSD'                                             => 'bsd',
 286             'Artistic'                                        => 'artistic',
 287         );
 288         while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
 289             $pattern =~ s{\s+}{\\s+}g;
 290             if ( $license_text =~ /\b$pattern\b/i ) {
 291                 $self->license($license);
 292                 return 1;
 293             }
 294         }
 295     }
 296
 297     warn "Cannot determine license info from $file\n";
 298     return 'unknown';
 299 }
 300
 301 1;