Changeset 8126 for inc

Timestamp:

12/09/05 04:08:27 (3 years ago)

Author:

autrijus

Message:

* bring more stuff forward from M::I 0.40.

Location:

inc/Module/Install

Files:

• Metadata.pm (modified) (11 diffs)
• Win32.pm (modified) (2 diffs)

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"
+#line 1 "inc/Module/Install/Metadata.pm - /usr/local/lib/perl5/site_perl/5.8.7/Module/Install/Metadata.pm"
 package Module::Install::Metadata;
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
+use Module::Install::Base;
+@ISA = qw(Module::Install::Base);
 
 $VERSION = '0.04';
@@ -10 +11 @@
 sub Meta { shift }
 
-my @scalar_keys = qw(
+my @scalar_keys = qw<
     name module_name version abstract author license
-    distribution_type sign perl_version
-);
-my @tuple_keys  = qw(build_requires requires recommends bundles);
+    distribution_type perl_version tests
+>;
+my @tuple_keys = qw<
+    build_requires requires recommends bundles
+>;
 
 foreach my $key (@scalar_keys) {
@@ -25 +28 @@
 }
 
+sub sign {
+    my $self = shift;
+    $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+    return $self;
+}
+
 foreach my $key (@tuple_keys) {
     *$key = sub {
         my $self = shift;
         return $self->{'values'}{$key} unless @_;
+
         my @rv;
         while (@_) {
-            my $module  = shift or last;
+            my $module = shift or last;
             my $version = shift || 0;
-            if ($module eq 'perl') {
+            if ( $module eq 'perl' ) {
                 $version =~ s{^(\d+)\.(\d+)\.(\d+)}
                              {$1 + $2/1_000 + $3/1_000_000}e;
@@ -39 +49 @@
                 next;
             }
-            my $rv = [$module, $version];
-            push @{$self->{'values'}{$key}}, $rv;
+            my $rv = [ $module, $version ];
             push @rv, $rv;
         }
-        return @rv;
+        push @{ $self->{'values'}{$key} }, @rv;
+        @rv;
     };
 }
 
+sub all_from {
+    my ( $self, $file ) = @_;
+
+    $self->version_from($file);
+    $self->perl_version_from($file);
+
+    # The remaining probes read from POD sections; if the file
+    # has an accompanying .pod, use that instead
+    my $pod = $file;
+    if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+        $file = $pod;
+    }
+
+    $self->abstract_from($file);
+    $self->license_from($file);
+}
+
+sub feature {
+    my $self     = shift;
+    my $name     = shift;
+    my $features = ( $self->{'values'}{'features'} ||= [] );
+
+    my $mods;
+
+    if ( @_ == 1 and ref( $_[0] ) ) {
+        # The user used ->feature like ->features by passing in the second
+        # argument as a reference.  Accomodate for that.
+        $mods = $_[0];
+    }
+    else {
+        $mods = \@_;
+    }
+
+    my $count = 0;
+    push @$features, (
+        $name => [
+            map {
+                ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
+                                                : @$_
+                        : $_
+            } @$mods
+        ]
+    );
+
+    return @$features;
+}
+
 sub features {
     my $self = shift;
-    while (my ($name, $mods) = splice(@_, 0, 2)) {
-        my $count = 0;
-        push @{$self->{'values'}{'features'}}, ($name => [
-            map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods
-        ] );
-    }
-    return @{$self->{'values'}{'features'}};
+    while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+        $self->feature( $name, @$mods );
+    }
+    return @{ $self->{'values'}{'features'} };
 }
 
@@ -61 +115 @@
     my $self = shift;
     my $type = shift;
-    push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type;
+    push @{ $self->{'values'}{'no_index'}{$type} }, @_ if $type;
     return $self->{'values'}{'no_index'};
 }
 
 sub _dump {
-    my $self = shift;
-    my $package = ref($self->_top);
+    my $self    = shift;
+    my $package = ref( $self->_top );
     my $version = $self->_top->VERSION;
-    my %values = %{$self->{'values'}};
+    my %values  = %{ $self->{'values'} };
 
     delete $values{sign};
-    if (my $perl_version = delete $values{perl_version}) {
-        # Always canonical to three-dot version 
-        $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
-            if $perl_version >= 5.006;
-        $values{requires} = [
-            [perl => $perl_version],
-            @{$values{requires}||[]},
-        ];
+    if ( my $perl_version = delete $values{perl_version} ) {
+
+        # Always canonical to three-dot version
+        $perl_version =~
+          s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
+          if $perl_version >= 5.006;
+        $values{requires} =
+          [ [ perl => $perl_version ], @{ $values{requires} || [] }, ];
     }
 
     warn "No license specified, setting license = 'unknown'\n"
-        unless $values{license};
-
-    $values{license} ||= 'unknown';
+      unless $values{license};
+
+    $values{license}           ||= 'unknown';
     $values{distribution_type} ||= 'module';
-    $values{name} ||= do {
+    $values{name}              ||= do {
         my $name = $values{module_name};
         $name =~ s/::/-/g;
@@ -93 +147 @@
     } if $values{module_name};
 
-    if ($values{name} =~ /::/) {
+    if ( $values{name} =~ /::/ ) {
         my $name = $values{name};
         $name =~ s/::/-/g;
@@ -106 +160 @@
         next unless exists $values{$key};
         $dump .= "$key:\n";
-        foreach (@{$values{$key}}) {
+        foreach ( @{ $values{$key} } ) {
             $dump .= "  $_->[0]: $_->[1]\n";
         }
     }
 
-    if (my $no_index = $values{no_index}) {
-        push @{$no_index->{'directory'}}, 'inc';
+    if ( my $no_index = $values{no_index} ) {
+        push @{ $no_index->{'directory'} }, 'inc';
         require YAML;
         local $YAML::UseHeader = 0;
-        $dump .= YAML::Dump({ no_index => $no_index});
+        $dump .= YAML::Dump( { no_index => $no_index } );
     }
     else {
@@ -124 +178 @@
 META
     }
-    
+
     $dump .= "generated_by: $package version $version\n";
     return $dump;
@@ -132 +186 @@
     my $self = shift;
     $self->include_deps( 'YAML', 0 );
+
     require YAML;
-    my $data = YAML::LoadFile( 'META.yml' );
+    my $data = YAML::LoadFile('META.yml');
+
     # Call methods explicitly in case user has already set some values.
-    while ( my ($key, $value) = each %$data ) {
-        next unless $self->can( $key );
-        if (ref $value eq 'HASH') {
-            while (my ($module, $version) = each %$value) {
-                $self->$key( $module => $version );
+    while ( my ( $key, $value ) = each %$data ) {
+        next unless $self->can($key);
+        if ( ref $value eq 'HASH' ) {
+            while ( my ( $module, $version ) = each %$value ) {
+                $self->can($key)->($self, $module => $version );
             }
         }
         else {
-            $self->$key( $value );
+            $self->can($key)->($self, $value);
         }
     }
@@ -153 +209 @@
     return $self unless $self->is_admin;
 
-    META_NOT_OURS: {
+  META_NOT_OURS: {
         local *FH;
-        if (open FH, "META.yml") {
+        if ( open FH, "META.yml" ) {
             while (<FH>) {
                 last META_NOT_OURS if /^generated_by: Module::Install\b/;
@@ -163 +219 @@
     }
 
-    warn "Writing META.yml\n";
+    print "Writing META.yml\n";
+
+    local *META;
     open META, "> META.yml" or warn "Cannot write to META.yml: $!";
     print META $self->_dump;
     close META;
+
     return $self;
 }
 
 sub version_from {
-    my ($self, $version_from) = @_;
+    my ( $self, $file ) = @_;
     require ExtUtils::MM_Unix;
-    my $version = ExtUtils::MM_Unix->parse_version($version_from);
-
-    if ($version !~ /^[\w\-\+\.]+/ and $] >= 5.006) {
-        $version = sprintf '%vd', $version;
-    }
-
-    $self->version($version);
+    $self->version( ExtUtils::MM_Unix->parse_version($file) );
 }
 
 sub abstract_from {
-    my ($self, $abstract_from) = @_;
+    my ( $self, $file ) = @_;
     require ExtUtils::MM_Unix;
     $self->abstract(
-        bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix')
-            ->parse_abstract($abstract_from)
-    );
+        bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )
+          ->parse_abstract($file) );
+}
+
+sub _slurp {
+    my ( $self, $file ) = @_;
+
+    local *FH;
+    open FH, "< $file" or die "Cannot open $file.pod: $!";
+    do { local $/; <FH> };
+}
+
+sub perl_version_from {
+    my ( $self, $file ) = @_;
+
+    if (
+        $self->_slurp($file) =~ m/
+        ^
+        use \s*
+        v?
+        ([\d\.]+)
+        \s* ;
+    /ixms
+      )
+    {
+        $self->perl_version($1);
+    }
+    else {
+        warn "Cannot determine perl version info from $file\n";
+        return;
+    }
+}
+
+sub license_from {
+    my ( $self, $file ) = @_;
+
+    if (
+        $self->_slurp($file) =~ m/
+        =head \d \s+
+        (?:licen[cs]e|licensing|copyright|legal)\b
+        (.*?)
+        (=head\\d.*|=cut.*|)
+        \z
+    /ixms
+      )
+    {
+        my $license_text = $1;
+        my @phrases      = (
+            'under the same (?:terms|license) as perl itself' => 'perl',
+            'GNU public license'                              => 'gpl',
+            'GNU lesser public license'                       => 'gpl',
+            'BSD license'                                     => 'bsd',
+            'Artistic license'                                => 'artistic',
+            'GPL'                                             => 'gpl',
+            'LGPL'                                            => 'lgpl',
+            'BSD'                                             => 'bsd',
+            'Artistic'                                        => 'artistic',
+        );
+        while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
+            $pattern =~ s{\s+}{\\s+}g;
+            if ( $license_text =~ /\b$pattern\b/i ) {
+                $self->license($license);
+                return 1;
+            }
+        }
+    }
+
+    warn "Cannot determine license info from $file\n";
+    return 'unknown';
 }
 

inc/Module/Install/Win32.pm

@@ -1 @@
-#line 1 "inc/Module/Install/Win32.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Win32.pm"
+#line 1 "inc/Module/Install/Win32.pm - /usr/local/lib/perl5/site_perl/5.8.7/Module/Install/Win32.pm"
 package Module::Install::Win32;
 use Module::Install::Base; @ISA = qw(Module::Install::Base);
@@ -18 +18 @@
         $Config::Config{make} =~ /^nmake\b/i    and
         $^O eq 'MSWin32'                        and
-        !$self->can_run('nmake.exe')
+        !$self->can_run('nmake')
     );