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