[Bast-commits] r9710 - in SQL-Abstract/1.x/trunk: . lib/SQL/Abstract t

[frew at dev.catalyst.perl.org]

Author: frew
Date: 2010-09-10 00:13:22 +0100 (Fri, 10 Sep 2010)
New Revision: 9710

Added:
   SQL-Abstract/1.x/trunk/t/12confmerge.t
Modified:
   SQL-Abstract/1.x/trunk/Changes
   SQL-Abstract/1.x/trunk/Makefile.PL
   SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Tree.pm
Log:
merge configs with profiles

Modified: SQL-Abstract/1.x/trunk/Changes
===================================================================
--- SQL-Abstract/1.x/trunk/Changes	2010-09-09 21:37:06 UTC (rev 9709)
+++ SQL-Abstract/1.x/trunk/Changes	2010-09-09 23:13:22 UTC (rev 9710)
@@ -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

Modified: SQL-Abstract/1.x/trunk/Makefile.PL
===================================================================
--- SQL-Abstract/1.x/trunk/Makefile.PL	2010-09-09 21:37:06 UTC (rev 9709)
+++ SQL-Abstract/1.x/trunk/Makefile.PL	2010-09-09 23:13:22 UTC (rev 9710)
@@ -13,6 +13,7 @@
 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;

Modified: SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Tree.pm
===================================================================
--- SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Tree.pm	2010-09-09 21:37:06 UTC (rev 9709)
+++ SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Tree.pm	2010-09-09 23:13:22 UTC (rev 9710)
@@ -5,7 +5,26 @@
 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';
 
 __PACKAGE__->mk_group_accessors( simple => $_ ) for qw(
@@ -170,10 +189,11 @@
 };
 
 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 @@
   return $keyword
 }
 
-
 my %starters = (
    select        => 1,
    update        => 1,

Added: SQL-Abstract/1.x/trunk/t/12confmerge.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/12confmerge.t	                        (rev 0)
+++ SQL-Abstract/1.x/trunk/t/12confmerge.t	2010-09-09 23:13:22 UTC (rev 9710)
@@ -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;