[Rt-commit] r4366 - in DBIx-SearchBuilder/trunk: . inc/Module/Install

jesse at bestpractical.com jesse at bestpractical.com
Thu Dec 29 08:39:20 EST 2005


Author: jesse
Date: Thu Dec 29 08:39:19 2005
New Revision: 4366

Modified:
   DBIx-SearchBuilder/trunk/   (props changed)
   DBIx-SearchBuilder/trunk/Changes
   DBIx-SearchBuilder/trunk/MANIFEST
   DBIx-SearchBuilder/trunk/META.yml
   DBIx-SearchBuilder/trunk/Makefile.PL
   DBIx-SearchBuilder/trunk/SearchBuilder.pm
   DBIx-SearchBuilder/trunk/inc/Module/Install.pm
   DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm
   DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm
   DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm
   DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm

Log:
 r21870 at truegrounds:  jesse | 2005-12-29 08:37:40 -0500
  * 1.38


Modified: DBIx-SearchBuilder/trunk/Changes
==============================================================================
--- DBIx-SearchBuilder/trunk/Changes	(original)
+++ DBIx-SearchBuilder/trunk/Changes	Thu Dec 29 08:39:19 2005
@@ -1,5 +1,8 @@
 Revision history for Perl extension DBIx::SearchBuilder.
 
+1.38 Thu Dec 29 03:17:54 EST 2005
+* Released 1.37 dev series
+
 1.37_01 Thu Dec  8 15:56:50 EST 2005
 * Switched Postgres sequence lookups to use CURRVAL, rather than OIDs
 

Modified: DBIx-SearchBuilder/trunk/MANIFEST
==============================================================================
--- DBIx-SearchBuilder/trunk/MANIFEST	(original)
+++ DBIx-SearchBuilder/trunk/MANIFEST	Thu Dec 29 08:39:19 2005
@@ -2,7 +2,7 @@
 ex/create_tables.pl
 ex/Example/Model/Address.pm
 ex/Example/Model/Employee.pm
-inc/ExtUtils/AutoInstall.pm
+inc/Module/AutoInstall.pm
 inc/Module/Install.pm
 inc/Module/Install/AutoInstall.pm
 inc/Module/Install/Base.pm

Modified: DBIx-SearchBuilder/trunk/META.yml
==============================================================================
--- DBIx-SearchBuilder/trunk/META.yml	(original)
+++ DBIx-SearchBuilder/trunk/META.yml	Thu Dec 29 08:39:19 2005
@@ -1,5 +1,5 @@
 name: DBIx-SearchBuilder
-version: 1.37_01
+version: 1.38
 license: perl
 distribution_type: module
 build_requires:
@@ -14,5 +14,6 @@
   Clone: 0
 no_index:
   directory:
+    - t
     - inc
-generated_by: Module::Install version 0.37
+generated_by: Module::Install version 0.46

Modified: DBIx-SearchBuilder/trunk/Makefile.PL
==============================================================================
--- DBIx-SearchBuilder/trunk/Makefile.PL	(original)
+++ DBIx-SearchBuilder/trunk/Makefile.PL	Thu Dec 29 08:39:19 2005
@@ -11,7 +11,7 @@
 requires('Clone');
 build_requires('Test::More' => 0.52);
 build_requires('DBD::SQLite');
-
+no_index( directory => 't');
 features(
 	'Lower case API' => [
 		-default => 0,

Modified: DBIx-SearchBuilder/trunk/SearchBuilder.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/SearchBuilder.pm	(original)
+++ DBIx-SearchBuilder/trunk/SearchBuilder.pm	Thu Dec 29 08:39:19 2005
@@ -4,7 +4,7 @@
 use strict;
 
 use vars qw($VERSION);
-$VERSION = "1.37_01";
+$VERSION = "1.38";
 
 use Clone qw();
 

Modified: DBIx-SearchBuilder/trunk/inc/Module/Install.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install.pm	(original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install.pm	Thu Dec 29 08:39:19 2005
@@ -1,6 +1,8 @@
-#line 1 "inc/Module/Install.pm - /usr/local/share/perl/5.8.7/Module/Install.pm"
+#line 1 "/home/jesse/svk/DBIx-SearchBuilder/inc/Module/Install.pm - /usr/local/share/perl/5.8.7/Module/Install.pm"
 package Module::Install;
-$VERSION = '0.37';
+use 5.004;
+
+$VERSION = '0.46';
 
 die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'};
 Please invoke ${\__PACKAGE__} with:
@@ -14,14 +16,31 @@
 .
 
 use strict 'vars';
-use Cwd ();
+use Cwd qw(cwd abs_path);
+use FindBin;
 use File::Find ();
 use File::Path ();
 
 @inc::Module::Install::ISA = 'Module::Install';
 *inc::Module::Install::VERSION = *VERSION;
 
-#line 130
+sub autoload {
+    my $self   = shift;
+    my $caller = $self->_caller;
+
+    my $cwd = cwd();
+    my $sym = "$caller\::AUTOLOAD";
+
+    $sym->{$cwd} = sub {
+        my $pwd = cwd();
+        if (my $code = $sym->{$pwd}) {
+            goto &$code unless $cwd eq $pwd; # delegate back to parent dirs
+        }
+        $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller - $sym";
+        unshift @_, ($self, $1);
+        goto &{$self->can('call')} unless uc($1) eq $1;
+    };
+}
 
 sub import {
     my $class = shift;
@@ -37,44 +56,61 @@
         goto &{"$self->{name}::import"};
     }
 
-    *{caller(0) . "::AUTOLOAD"} = $self->autoload;
+    *{$self->_caller . "::AUTOLOAD"} = $self->autoload;
+    $self->preload;
 
     # Unregister loader and worker packages so subdirs can use them again
     delete $INC{"$self->{file}"};
     delete $INC{"$self->{path}.pm"};
 }
 
-#line 157
+sub preload {
+    my ($self) = @_;
 
-sub autoload {
-    my $self = shift;
-    my $caller = caller;
+    $self->load_extensions(
+        "$self->{prefix}/$self->{path}", $self
+    ) unless $self->{extensions};
 
-    my $cwd = Cwd::cwd();
-    my $sym = "$caller\::AUTOLOAD";
+    my @exts = @{$self->{extensions}};
 
-    $sym->{$cwd} = sub {
-        my $pwd = Cwd::cwd();
-        if (my $code = $sym->{$pwd}) {
-            goto &$code unless $cwd eq $pwd; # delegate back to parent dirs
+    unless (@exts) {
+        my $admin = $self->{admin};
+        @exts = $admin->load_all_extensions;
+    }
+
+    my %seen_method;
+    foreach my $obj (@exts) {
+        while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+            next unless defined *{$glob}{CODE};
+            next if $method =~ /^_/;
+            next if $method eq uc($method);
+            $seen_method{$method}++;
         }
-        $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller";
-        unshift @_, ($self, $1);
-        goto &{$self->can('call')} unless uc($1) eq $1;
-    };
-}
+    }
 
-#line 182
+    my $caller = $self->_caller;
+    foreach my $name (sort keys %seen_method) {
+        *{"${caller}::$name"} = sub {
+            ${"${caller}::AUTOLOAD"} = "${caller}::$name";
+            goto &{"${caller}::AUTOLOAD"};
+        };
+    }
+}
 
 sub new {
     my ($class, %args) = @_;
 
+    # ignore the prefix on extension modules built from top level.
+    my $base_path = abs_path($FindBin::Bin);
+    delete $args{prefix} unless abs_path(cwd()) eq $base_path;
+
     return $args{_self} if $args{_self};
 
     $args{dispatch} ||= 'Admin';
     $args{prefix}   ||= 'inc';
     $args{author}   ||= '.author';
     $args{bundle}   ||= 'inc/BUNDLES';
+    $args{base}     ||= $base_path;
 
     $class =~ s/^\Q$args{prefix}\E:://;
     $args{name}     ||= $class;
@@ -84,24 +120,20 @@
         $args{path}  = $args{name};
         $args{path}  =~ s!::!/!g;
     }
-    $args{file}     ||= "$args{prefix}/$args{path}.pm";
+    $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 
     bless(\%args, $class);
 }
 
-#line 211
-
 sub call {
     my $self   = shift;
     my $method = shift;
-    my $obj = $self->load($method) or return;
+    my $obj    = $self->load($method) or return;
 
     unshift @_, $obj;
     goto &{$obj->can($method)};
 }
 
-#line 226
-
 sub load {
     my ($self, $method) = @_;
 
@@ -124,8 +156,6 @@
     $obj;
 }
 
-#line 256
-
 sub load_extensions {
     my ($self, $path, $top_obj) = @_;
 
@@ -137,13 +167,15 @@
         my ($file, $pkg) = @{$rv};
         next if $self->{pathnames}{$pkg};
 
-        eval { require $file; 1 } or (warn($@), next);
+        local $@;
+        my $new = eval { require $file; $pkg->can('new') };
+        if (!$new) { warn $@ if $@; next; }
         $self->{pathnames}{$pkg} = delete $INC{$file};
-        push @{$self->{extensions}}, $pkg->new( _top => $top_obj );
+        push @{$self->{extensions}}, &{$new}($pkg, _top => $top_obj );
     }
-}
 
-#line 280
+    $self->{extensions} ||= [];
+}
 
 sub find_extensions {
     my ($self, $path) = @_;
@@ -162,8 +194,16 @@
     @found;
 }
 
-1;
+sub _caller {
+    my $depth = 0;
+    my $caller = caller($depth);
+
+    while ($caller eq __PACKAGE__) {
+        $depth++;
+        $caller = caller($depth);
+    }
 
-__END__
+    $caller;
+}
 
-#line 618
+1;

Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm	(original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm	Thu Dec 29 08:39:19 2005
@@ -22,31 +22,31 @@
     my @core = map @$_, map @$_, grep ref,
                $self->build_requires, $self->requires;
 
-    while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
-        push @core, splice(@_, 0, 2);
-    }
-
-    # We'll need ExtUtils::AutoInstall
-    $self->include('ExtUtils::AutoInstall');
-    require ExtUtils::AutoInstall;
+    my @config = @_;
 
-    ExtUtils::AutoInstall->import(
-        (@core ? (-core => \@core) : ()), @_, $self->features
+    # We'll need Module::AutoInstall
+    $self->include('Module::AutoInstall');
+    require Module::AutoInstall;
+
+    Module::AutoInstall->import(
+        (@config ? (-config => \@config) : ()),
+        (@core   ? (-core   => \@core)   : ()),
+        $self->features,
     );
 
-    $self->makemaker_args( ExtUtils::AutoInstall::_make_args() );
+    $self->makemaker_args( Module::AutoInstall::_make_args() );
 
     my $class = ref($self);
     $self->postamble(
         "# --- $class section:\n" .
-        ExtUtils::AutoInstall::postamble()
+        Module::AutoInstall::postamble()
     );
 }
 
 sub auto_install_now {
     my $self = shift;
-    $self->auto_install;
-    ExtUtils::AutoInstall::do_install();
+    $self->auto_install(@_);
+    Module::AutoInstall::do_install();
 }
 
 1;

Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm	(original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm	Thu Dec 29 08:39:19 2005
@@ -1,7 +1,10 @@
 #line 1 "inc/Module/Install/Base.pm - /usr/local/share/perl/5.8.7/Module/Install/Base.pm"
 package Module::Install::Base;
 
-#line 28
+# Suspend handler for "redefined" warnings
+BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w } };
+
+#line 31
 
 sub new {
     my ($class, %args) = @_;
@@ -15,18 +18,18 @@
     bless(\%args, $class);
 }
 
-#line 46
+#line 49
 
 sub AUTOLOAD {
     my $self = shift;
     goto &{$self->_top->autoload};
 }
 
-#line 57
+#line 60
 
 sub _top { $_[0]->{_top} }
 
-#line 68
+#line 71
 
 sub admin {
     my $self = shift;
@@ -49,6 +52,9 @@
 
 1;
 
+# Restore warning handler
+BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->() };
+
 __END__
 
-#line 112
+#line 118

Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm	(original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm	Thu Dec 29 08:39:19 2005
@@ -23,6 +23,14 @@
     $args;
 }
 
+sub build_subdirs {
+    my $self = shift;
+    my $subdirs = $self->makemaker_args->{DIR} ||= [];
+    for my $subdir (@_) {
+        push @$subdirs, $subdir;
+    }
+}
+
 sub clean_files {
     my $self = shift;
     my $clean = $self->makemaker_args->{clean} ||= {};
@@ -53,7 +61,8 @@
     $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
     $args->{VERSION} = $self->version || $self->determine_VERSION($args);
     $args->{NAME} =~ s/-/::/g;
-    $args->{test} = {TESTS => $self->tests};
+
+    $args->{test} = {TESTS => $self->tests} if $self->tests;
 
     if ($] >= 5.005) {
 	$args->{ABSTRACT} = $self->abstract;
@@ -73,10 +82,13 @@
                  ($self->build_requires, $self->requires) );
 
     # merge both kinds of requires into prereq_pm
-    my $dir = ($args->{DIR} ||= []);
+    my $subdirs = ($args->{DIR} ||= []);
     if ($self->bundles) {
-        push @$dir, map "$_->[1]", @{$self->bundles};
-        delete $prereq->{$_->[0]} for @{$self->bundles};
+        foreach my $bundle (@{ $self->bundles }) {
+            my ($file, $dir) = @$bundle;
+            push @$subdirs, $dir if -d $dir;
+            delete $prereq->{$file};
+        }
     }
 
     if (my $perl_version = $self->perl_version) {
@@ -107,6 +119,7 @@
     my $postamble = "# Postamble by $top_class $top_version\n" . 
                     ($self->postamble || '');
 
+    local *MAKEFILE;
     open MAKEFILE, '< Makefile' or die $!;
     my $makefile = do { local $/; <MAKEFILE> };
     close MAKEFILE;
@@ -141,4 +154,4 @@
 
 __END__
 
-#line 274
+#line 287

Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm	(original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm	Thu Dec 29 08:39:19 2005
@@ -1,6 +1,7 @@
 #line 1 "inc/Module/Install/Metadata.pm - /usr/local/share/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;
+ at ISA = qw(Module::Install::Base);
 
 $VERSION = '0.04';
 
@@ -9,11 +10,13 @@
 
 sub Meta { shift }
 
-my @scalar_keys = qw(
+my @scalar_keys = qw<
     name module_name version abstract author license
-    distribution_type sign perl_version tests
-);
-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) {
     *$key = sub {
@@ -24,75 +27,152 @@
     };
 }
 
+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;
                 $self->perl_version($version);
                 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)      unless $self->version;
+    $self->perl_version_from($file) unless $self->perl_version;
+
+    # 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->author_from($file)   unless $self->author;
+    $self->license_from($file)  unless $self->license;
+    $self->abstract_from($file) unless $self->abstract;
+}
+
+sub provides {
+    my $self     = shift;
+    my $provides = ( $self->{'values'}{'provides'} ||= {} );
+    %$provides = (%$provides, @_) if @_;
+    return $provides;
+}
+
+sub auto_provides {
+    my $self = shift;
+    return $self unless $self->is_admin;
+
+    unless (-e 'MANIFEST') {
+        warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+        return $self;
+    }
+
+    require Module::Build;
+    my $build = Module::Build->new(
+        dist_name    => $self->{name},
+        dist_version => $self->{version},
+        license      => $self->{license},
+    );
+    $self->provides(%{ $build->find_dist_packages || {} });
+}
+
+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
-        ] );
+    while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+        $self->feature( $name, @$mods );
     }
-    return @{$self->{'values'}{'features'}};
+    return @{ $self->{'values'}{'features'} };
 }
 
 sub no_index {
     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};
+      unless $values{license};
 
-    $values{license} ||= 'unknown';
+    $values{license}           ||= 'unknown';
     $values{distribution_type} ||= 'module';
-    $values{name} ||= do {
+    $values{name}              ||= do {
         my $name = $values{module_name};
         $name =~ s/::/-/g;
         $name;
     } if $values{module_name};
 
-    if ($values{name} =~ /::/) {
+    if ( $values{name} =~ /::/ ) {
         my $name = $values{name};
         $name =~ s/::/-/g;
         die "Error in name(): '$values{name}' should be '$name'!\n";
@@ -105,16 +185,22 @@
     foreach my $key (@tuple_keys) {
         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 $provides = $values{provides} ) {
         require YAML;
         local $YAML::UseHeader = 0;
-        $dump .= YAML::Dump({ no_index => $no_index});
+        $dump .= YAML::Dump( { provides => $provides } );
+    }
+
+    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 } );
     }
     else {
         $dump .= << "META";
@@ -123,7 +209,7 @@
     - inc
 META
     }
-    
+
     $dump .= "generated_by: $package version $version\n";
     return $dump;
 }
@@ -131,18 +217,20 @@
 sub read {
     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);
         }
     }
     return $self;
@@ -152,9 +240,9 @@
     my $self = shift;
     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/;
             }
@@ -162,26 +250,116 @@
         }
     }
 
-    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;
-    $self->version(ExtUtils::MM_Unix->parse_version($version_from));
+    $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 author_from {
+    my ( $self, $file ) = @_;
+    my $content = $self->_slurp($file);
+    if ($content =~ m/
+        =head \d \s+ (?:authors?)\b \s*
+        ([^\n]*)
+        |
+        =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+        .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+        ([^\n]*)
+    /ixms) {
+        my $author = $1 || $2;
+        $author =~ s{E<lt>}{<}g;
+        $author =~ s{E<gt>}{>}g;
+        $self->author($author); 
+    }
+    else {
+        warn "Cannot determine author info from $file\n";
+    }
+}
+
+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';
 }
 
 1;


More information about the Rt-commit mailing list