From: Karen Etheridge <ether@cpan.org>
Date: Sat, 17 Dec 2011 00:42:25 +0000 (+0000)
Subject: fix for RT#73325 - call the configfile default sub if it is a sub
X-Git-Tag: 0.04~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=56e4351b360e0c6e8f24d83c1bf2af08b1fdb17e;p=gitmo%2FMooseX-ConfigFromFile.git

fix for RT#73325 - call the configfile default sub if it is a sub
---

diff --git a/ChangeLog b/ChangeLog
index cb040dd..d9b4e27 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 Revision history for Perl extension MooseX::ConfigFromFile
 
+{{$NEXT}}
+    - Call the configfile attribute default sub if it is a sub, not just a
+      string, just like MooseX::Getopt does (RT#73325, Karen Etheridge)
+
 0.03 - Dec 18, 2010
     - The test suite now uses Test::Fatal instead of Test::Exception (Karen
       Etheridge).
diff --git a/lib/MooseX/ConfigFromFile.pm b/lib/MooseX/ConfigFromFile.pm
index 2137247..5557c53 100644
--- a/lib/MooseX/ConfigFromFile.pm
+++ b/lib/MooseX/ConfigFromFile.pm
@@ -29,6 +29,9 @@ sub new_with_config {
         my $cfmeta = $class->meta->find_attribute_by_name('configfile');
         $configfile = try { to_File($class->configfile) };
         $configfile ||= $cfmeta->default if $cfmeta->has_default;
+        if (ref $configfile eq 'CODE') {
+            $configfile = &$configfile($class);
+        }
     }
 
     if (defined $configfile) {
diff --git a/t/03configfile_method.t b/t/03configfile_method.t
index 4c3f4f8..362ba2f 100644
--- a/t/03configfile_method.t
+++ b/t/03configfile_method.t
@@ -2,14 +2,21 @@
 use strict;
 use Test::More;
 use Test::Fatal;
+
+
+my %config_from_file_args;
 {
     package A;
     use Moose;
     with qw(MooseX::ConfigFromFile);
 
-    sub configfile { 'moo' }
+    sub configfile { die 'should not ever be here' }
 
-    sub get_config_from_file { {} }
+    sub get_config_from_file {
+        my ($class, $file) = @_;
+        $config_from_file_args{$class} = $file;
+        return {};
+    }
 }
 
 {
@@ -19,10 +26,32 @@ use Test::Fatal;
 
     sub configfile { die; }
     has configfile => ( is => 'bare', default => 'bar' );
+}
 
+{
+    package C;
+    use Moose;
+    extends qw(A);
+
+    sub configfile { die; }
+    has configfile => (
+        is => 'bare',
+        default => sub {
+            my $class = shift;
+            $class = blessed($class) || $class;
+            '/dir/' . $class;
+        },
+    );
 }
 
 is(exception { A->new_with_config() }, undef, 'A->new_with_config lives');
+is($config_from_file_args{A}, undef, 'there is no configfile for A');
+
 is(exception { B->new_with_config() }, undef, 'B->new_with_config lives');
+is($config_from_file_args{B}, 'bar', 'B configfile attr default sub is called');
+
+is(exception { C->new_with_config() }, undef, 'C->new_with_config lives');
+is($config_from_file_args{C}, '/dir/C', 'C configfile attr default sub is called, with classname');
+
 
 done_testing();