inc/Module/Install/Metadata.pm

   1 #line 1 "inc/Module/Install/Metadata.pm - /Library/Perl/5.8.1/Module/Install/Metadata.pm"
   2 # $File: //depot/cpan/Module-Install/lib/Module/Install/Metadata.pm $ $Author: autrijus $
   3 # $Revision: #32 $ $Change: 1885 $ $DateTime: 2004/03/11 05:55:27 $ vim: expandtab shiftwidth=4
   4
   5 package Module::Install::Metadata;
   6 use Module::Install::Base; @ISA = qw(Module::Install::Base);
   7
   8 $VERSION = '0.04';
   9
  10 use strict 'vars';
  11 use vars qw($VERSION);
  12
  13 sub Meta { shift }
  14
  15 my @scalar_keys = qw(
  16     name module_name version abstract author license
  17     distribution_type sign perl_version
  18 );
  19 my @tuple_keys  = qw(build_requires requires recommends bundles);
  20
  21 foreach my $key (@scalar_keys) {
  22     *$key = sub {
  23         my $self = shift;
  24         return $self->{'values'}{$key} unless @_;
  25         $self->{'values'}{$key} = shift;
  26         return $self;
  27     };
  28 }
  29
  30 foreach my $key (@tuple_keys) {
  31     *$key = sub {
  32         my $self = shift;
  33         return $self->{'values'}{$key} unless @_;
  34         my @rv;
  35         while (@_) {
  36             my $module  = shift or last;
  37             my $version = shift || 0;
  38             if ($module eq 'perl') {
  39                 $version =~ s{^(\d+)\.(\d+)\.(\d+)}
  40                              {$1 + $2/1_000 + $3/1_000_000}e;
  41                 $self->perl_version($version);
  42                 next;
  43             }
  44             my $rv = [$module, $version];
  45             push @{$self->{'values'}{$key}}, $rv;
  46             push @rv, $rv;
  47         }
  48         return @rv;
  49     };
  50 }
  51
  52 sub features {
  53     my $self = shift;
  54     while (my ($name, $mods) = splice(@_, 0, 2)) {
  55         my $count = 0;
  56         push @{$self->{'values'}{'features'}}, ($name => [
  57             map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods
  58         ] );
  59     }
  60     return @{$self->{'values'}{'features'}};
  61 }
  62
  63 sub no_index {
  64     my $self = shift;
  65     my $type = shift;
  66     push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type;
  67     return $self->{'values'}{'no_index'};
  68 }
  69
  70 sub _dump {
  71     my $self = shift;
  72     my $package = ref($self->_top);
  73     my $version = $self->_top->VERSION;
  74     my %values = %{$self->{'values'}};
  75
  76     delete $values{sign};
  77     if (my $perl_version = delete $values{perl_version}) {
  78         # Always canonical to three-dot version
  79         $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
  80             if $perl_version >= 5.006;
  81         $values{requires} = [
  82             [perl => $perl_version],
  83             @{$values{requires}||[]},
  84         ];
  85     }
  86
  87     warn "No license specified, setting license = 'unknown'\n"
  88         unless $values{license};
  89
  90     $values{license} ||= 'unknown';
  91     $values{distribution_type} ||= 'module';
  92     $values{name} ||= do {
  93         my $name = $values{module_name};
  94         $name =~ s/::/-/g;
  95         $name;
  96     } if $values{module_name};
  97
  98     if ($values{name} =~ /::/) {
  99         my $name = $values{name};
 100         $name =~ s/::/-/g;
 101         die "Error in name(): '$values{name}' should be '$name'!\n";
 102     }
 103
 104     my $dump = '';
 105     foreach my $key (@scalar_keys) {
 106         $dump .= "$key: $values{$key}\n" if exists $values{$key};
 107     }
 108     foreach my $key (@tuple_keys) {
 109         next unless exists $values{$key};
 110         $dump .= "$key:\n";
 111         foreach (@{$values{$key}}) {
 112             $dump .= "  $_->[0]: $_->[1]\n";
 113         }
 114     }
 115
 116     if (my $no_index = $values{no_index}) {
 117         push @{$no_index->{'directory'}}, 'inc';
 118         require YAML;
 119         local $YAML::UseHeader = 0;
 120         $dump .= YAML::Dump({ no_index => $no_index});
 121     }
 122     else {
 123         $dump .= << "META";
 124 no_index:
 125   directory:
 126     - inc
 127 META
 128     }
 129
 130     $dump .= "generated_by: $package version $version\n";
 131     return $dump;
 132 }
 133
 134 sub read {
 135     my $self = shift;
 136     $self->include_deps( 'YAML', 0 );
 137     require YAML;
 138     my $data = YAML::LoadFile( 'META.yml' );
 139     # Call methods explicitly in case user has already set some values.
 140     while ( my ($key, $value) = each %$data ) {
 141         next unless $self->can( $key );
 142         if (ref $value eq 'HASH') {
 143             while (my ($module, $version) = each %$value) {
 144                 $self->$key( $module => $version );
 145             }
 146         }
 147         else {
 148             $self->$key( $value );
 149         }
 150     }
 151     return $self;
 152 }
 153
 154 sub write {
 155     my $self = shift;
 156     return $self unless $self->is_admin;
 157
 158     META_NOT_OURS: {
 159         local *FH;
 160         if (open FH, "META.yml") {
 161             while (<FH>) {
 162                 last META_NOT_OURS if /^generated_by: Module::Install\b/;
 163             }
 164             return $self if -s FH;
 165         }
 166     }
 167
 168     warn "Writing META.yml\n";
 169     open META, "> META.yml" or warn "Cannot write to META.yml: $!";
 170     print META $self->_dump;
 171     close META;
 172     return $self;
 173 }
 174
 175 sub version_from {
 176     my ($self, $version_from) = @_;
 177     require ExtUtils::MM_Unix;
 178     $self->version(ExtUtils::MM_Unix->parse_version($version_from));
 179 }
 180
 181 sub abstract_from {
 182     my ($self, $abstract_from) = @_;
 183     require ExtUtils::MM_Unix;
 184     $self->abstract(
 185         bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix')
 186             ->parse_abstract($abstract_from)
 187     );
 188 }
 189
 190 1;