support for _get_default_configfile - RT#79746

diff --git a/ChangeLog b/ChangeLog
index 9fc11cf..9d16329 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 Revision history for Perl extension MooseX::ConfigFromFile
 
+0.05
+    - new _get_default_configfile method added, which consumers can override
+    to provide a default value without having to redefine the attribute itself
+    (via RT#79746)
+
 0.04 - Dec 17, 2011
     - Call the configfile attribute default sub if it is a sub, not just a
       string, just like MooseX::Getopt does (RT#73325, Karen Etheridge)

diff --git a/lib/MooseX/ConfigFromFile.pm b/lib/MooseX/ConfigFromFile.pm
index b08dde0..03b3227 100644 (file)
--- a/lib/MooseX/ConfigFromFile.pm
+++ b/lib/MooseX/ConfigFromFile.pm
@@ -17,6 +17,10 @@ has configfile => (
     predicate => 'has_configfile',
 );
 
+# overridable in consuming class or role to provide a default value
+# called before instantiation, so must be a class method!
+sub _get_default_configfile { }
+
 sub new_with_config {
     my ($class, %opts) = @_;
 
@@ -26,12 +30,23 @@ sub new_with_config {
         $configfile = $opts{configfile}
     }
     else {
-        my $cfmeta = $class->meta->find_attribute_by_name('configfile');
+        # This would only succeed if the consumer had changed the name of the
+        # reader method, and defined a new configfile sub in its place
         $configfile = try { to_File($class->configfile) };
-        $configfile ||= $cfmeta->default if $cfmeta->has_default;
+
+        # this is gross, but since a lot of users have swapped in their own
+        # default subs, we have to keep calling it rather than calling a
+        # builder sub directly - and it might not even be a coderef either
+        my $cfmeta = $class->meta->find_attribute_by_name('configfile');
+        $configfile ||= $cfmeta->default;
+
         if (ref $configfile eq 'CODE') {
-            $configfile = &$configfile($class);
+            $configfile = $configfile->($class);
         }
+
+        $configfile ||= $class->_get_default_configfile;
+
+        $opts{$cfmeta->init_arg} = $configfile if defined $configfile;
     }
 
     if (defined $configfile) {

diff --git a/t/05_default_sub.t b/t/05_default_sub.t
new file mode 100644 (file)
index 0000000..b36d06e
--- /dev/null
+++ b/t/05_default_sub.t
@@ -0,0 +1,184 @@
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Fatal;
+use Test::Deep '!blessed';
+use Test::NoWarnings 1.04 ':early';
+use Scalar::Util 'blessed';
+
+my %loaded_file;
+my %constructor_args;
+my %default_sub;
+
+
+# nothing special going on here
+{
+    package Generic;
+    use Moose;
+    with 'MooseX::SimpleConfig';
+    sub get_config_from_file { }
+}
+
+is(
+    exception {
+        my $obj = Generic->new_with_config;
+        is($obj->configfile, undef, 'no configfile set');
+    },
+    undef,
+    'no exceptions',
+);
+
+
+# this is a classic legacy usecase that we must continue to support
+{
+    package OverriddenDefault;
+    use Moose;
+    with 'MooseX::SimpleConfig';
+    sub get_config_from_file
+    {
+        my ($class, $file) = @_;
+        $loaded_file{$file}++;
+        +{}
+    }
+    has '+configfile' => (
+        default => 'OverriddenDefault file',
+    );
+}
+
+is(
+    exception {
+        my $obj = OverriddenDefault->new_with_config;
+        is($obj->configfile, 'OverriddenDefault file', 'configfile set via overridden default');
+        is($loaded_file{'OverriddenDefault file'}, 1, 'correct file was loaded from');
+    },
+    undef,
+    'no exceptions',
+);
+
+
+# legacy usecase, and configfile init_arg has been changed
+{
+    package OverriddenDefaultAndChangedName;
+    use Moose;
+    with 'MooseX::SimpleConfig';
+    sub get_config_from_file
+    {
+        my ($class, $file) = @_;
+        $loaded_file{$file}++;
+        +{}
+    }
+    has '+configfile' => (
+        init_arg => 'my_configfile',
+        default => 'OverriddenDefaultAndChangedName file',
+    );
+    around BUILDARGS => sub {
+        my ($orig, $class) = (shift, shift);
+        my $args = $class->$orig(@_);
+        $constructor_args{$class} = $args;
+    };
+}
+
+is(
+    exception {
+        my $obj = OverriddenDefaultAndChangedName->new_with_config;
+        is($obj->configfile, blessed($obj) . ' file', 'configfile set via overridden default');
+        cmp_deeply(
+            $constructor_args{blessed($obj)},
+            {  my_configfile => blessed($obj) . ' file' },
+            'correct constructor args passed',
+        );
+        is($loaded_file{blessed($obj) . ' file'}, 1, 'correct file was loaded from');
+    },
+    undef,
+    'no exceptions',
+);
+
+
+# newly-supported overridable method for configfile default
+{
+    package WrapperSub;
+    use Moose;
+    with 'MooseX::SimpleConfig';
+    sub get_config_from_file
+    {
+        my ($class, $file) = @_;
+        $loaded_file{$file}++;
+        +{}
+    }
+
+    sub _get_default_configfile {
+        my $class = shift;
+        $default_sub{$class}++;
+        $class . ' file'
+    }
+
+    around BUILDARGS => sub {
+        my ($orig, $class) = (shift, shift);
+        my $args = $class->$orig(@_);
+        $constructor_args{$class} = $args;
+    };
+}
+
+is(
+    exception {
+        my $obj = WrapperSub->new_with_config;
+        is($obj->configfile, blessed($obj) . ' file', 'configfile set via overridden sub');
+        cmp_deeply(
+            $constructor_args{blessed($obj)},
+            {  configfile => blessed($obj) . ' file' },
+            'correct constructor args passed',
+        );
+        is($default_sub{blessed($obj)}, 1, 'default sub called just once');
+        is($loaded_file{blessed($obj) . ' file'}, 1, 'correct file was loaded from');
+    },
+    undef,
+    'no exceptions',
+);
+
+
+# newly-supported overridable method for configfile default, and configfile
+# init_arg has been changed
+{
+    package WrapperSubAndChangedName;
+    use Moose;
+    with 'MooseX::SimpleConfig';
+    has '+configfile' => (
+        init_arg => 'my_configfile',
+    );
+    sub get_config_from_file
+    {
+        my ($class, $file) = @_;
+        $loaded_file{$file}++;
+        +{}
+    }
+
+    sub _get_default_configfile {
+        my $class = shift;
+        $default_sub{$class}++;
+        $class . ' file'
+    }
+
+    around BUILDARGS => sub {
+        my ($orig, $class) = (shift, shift);
+        my $args = $class->$orig(@_);
+        $constructor_args{$class} = $args;
+    };
+}
+
+is(
+    exception {
+        my $obj = WrapperSubAndChangedName->new_with_config;
+        is($obj->configfile, blessed($obj) . ' file', 'configfile set via overridden sub');
+        cmp_deeply(
+            $constructor_args{blessed($obj)},
+            {  my_configfile => blessed($obj) . ' file' },
+            'correct constructor args passed',
+        );
+        is($default_sub{blessed($obj)}, 1, 'default sub called just once');
+        is($loaded_file{blessed($obj) . ' file'}, 1, 'correct file was loaded from');
+    },
+    undef,
+    'no exceptions',
+);
+