merge configs with profiles

diff --git a/Changes b/Changes
index 56778db..ad898a7 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,7 +1,8 @@
 Revision history for SQL::Abstract
 
-revision 1.67_03  2010-09-08
+revision 1.67_03  2010-09-
 ----------------------------
+    - correcty merge profile and parameters
     - added fill_in_placeholders option for excellent copy/pasta
 
 revision 1.67_02  2010-09-08

diff --git a/Makefile.PL b/Makefile.PL
index 8c796f4..213d17e 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -13,6 +13,7 @@ all_from 'lib/SQL/Abstract.pm';
 requires 'List::Util'   => 0;
 requires 'Scalar::Util' => 0;
 requires 'Class::Accessor::Grouped' => 0.09005;
+requires 'Hash::Merge' => 0.12;
 
 test_requires "Test::More"      => 0.92;
 test_requires "Test::Exception" => 0;

diff --git a/lib/SQL/Abstract/Tree.pm b/lib/SQL/Abstract/Tree.pm
index b1ec93d..ada82df 100644 (file)
--- a/lib/SQL/Abstract/Tree.pm
+++ b/lib/SQL/Abstract/Tree.pm
@@ -5,6 +5,25 @@ use warnings;
 use Carp;
 
 use List::Util;
+use Hash::Merge 'merge';
+
+Hash::Merge::specify_behavior({
+   SCALAR => {
+      SCALAR => sub { $_[1] },
+      ARRAY  => sub { [ $_[0], @{$_[1]} ] },
+      HASH   => sub { $_[1] },
+   },
+   ARRAY => {
+      SCALAR => sub { $_[1] },
+      ARRAY  => sub { $_[1] },
+      HASH   => sub { $_[1] },
+   },
+   HASH => {
+      SCALAR => sub { $_[1] },
+      ARRAY  => sub { [ values %{$_[0]}, @{$_[1]} ] },
+      HASH   => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
+   },
+}, 'My Behavior' );
 
 use base 'Class::Accessor::Grouped';
 
@@ -170,10 +189,11 @@ eval {
 };
 
 sub new {
-   my ($class, $args) = @_;
+   my $class = shift;
+   my $args  = shift || {};
 
    my $profile = delete $args->{profile} || 'none';
-   my $data = {%{$profiles{$profile}}, %{$args||{}}};
+   my $data = merge( $profiles{$profile}, $args );
 
    bless $data, $class
 }
@@ -281,7 +301,6 @@ sub format_keyword {
   return $keyword
 }
 
-
 my %starters = (
    select        => 1,
    update        => 1,

diff --git a/t/12confmerge.t b/t/12confmerge.t
new file mode 100644 (file)
index 0000000..dc6e949
--- /dev/null
+++ b/t/12confmerge.t
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use SQL::Abstract::Tree;
+
+my $tree = SQL::Abstract::Tree->new({
+   profile  => 'console',
+   colormap => {
+      select     => undef,
+      'group by' => ['yo', 'seph'] ,
+   },
+});
+
+is $tree->newline, "\n", 'console profile appears to have been used';
+ok !defined $tree->colormap->{select}, 'select correctly got undefined from colormap';
+
+ok eq_array($tree->colormap->{'group by'}, [qw(yo seph)]), 'group by correctly got overridden';
+ok ref $tree->colormap->{'order by'}, 'but the rest of the colormap does not get blown away';
+
+done_testing;