[Bast-commits] r5215 - in SQL-Abstract/1.x/branches/1.50_RC: .
lib/SQL/Abstract t
norbi at dev.catalyst.perl.org
norbi at dev.catalyst.perl.org
Wed Nov 26 22:35:33 GMT 2008
Author: norbi
Date: 2008-11-26 22:35:33 +0000 (Wed, 26 Nov 2008)
New Revision: 5215
Added:
SQL-Abstract/1.x/branches/1.50_RC/t/10test.t
Modified:
SQL-Abstract/1.x/branches/1.50_RC/
SQL-Abstract/1.x/branches/1.50_RC/MANIFEST
SQL-Abstract/1.x/branches/1.50_RC/lib/SQL/Abstract/Test.pm
Log:
r5276 at vger: mendel | 2008-11-26 23:35:09 +0100
* Reimplemented SQL::Abstract::Test::eq_bind to compare the data structures instead of stringifying them.
* Added tests for eq_bind.
Property changes on: SQL-Abstract/1.x/branches/1.50_RC
___________________________________________________________________
Name: svk:merge
- 4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC:5275
+ 4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC:5276
Modified: SQL-Abstract/1.x/branches/1.50_RC/MANIFEST
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC/MANIFEST 2008-11-26 22:35:25 UTC (rev 5214)
+++ SQL-Abstract/1.x/branches/1.50_RC/MANIFEST 2008-11-26 22:35:33 UTC (rev 5215)
@@ -12,5 +12,4 @@
t/07subqueries.t
t/08special_ops.t
t/09refkind.t
-
-
+t/10test.t
Modified: SQL-Abstract/1.x/branches/1.50_RC/lib/SQL/Abstract/Test.pm
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC/lib/SQL/Abstract/Test.pm 2008-11-26 22:35:25 UTC (rev 5214)
+++ SQL-Abstract/1.x/branches/1.50_RC/lib/SQL/Abstract/Test.pm 2008-11-26 22:35:33 UTC (rev 5215)
@@ -3,6 +3,7 @@
use strict;
use warnings;
use base qw/Test::Builder::Module Exporter/;
+use Scalar::Util qw(looks_like_number blessed reftype);
use Data::Dumper;
use Carp;
@@ -41,31 +42,61 @@
}
}
-
sub eq_bind {
my ($bind_ref1, $bind_ref2) = @_;
- return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);
-}
-sub stringify_bind {
- my $bind_ref = shift || [];
+ my $ref1 = ref $bind_ref1;
+ my $ref2 = ref $bind_ref2;
- # some bind values can be arrayrefs (see L<SQL::Abstract/bindtype>),
- # so stringify them.
- # furthermore, if L<SQL::Abstract/array_datatypes> is set to true, elements
- # of those arrayrefs can be arrayrefs, too.
- my @strings = map {
- ref $_ eq 'ARRAY'
- ? join('=>', map {
- ref $_ eq 'ARRAY'
- ? ('[' . join('=>', @$_) . ']')
- : (defined $_ ? $_ : '')
- } @$_)
- : (defined $_ ? $_ : '')
- } @$bind_ref;
+ return 0 if $ref1 ne $ref2;
- # join all values into a single string
- return join "///", @strings;
+ if ($ref1 eq 'SCALAR' || $ref1 eq 'REF') {
+ return eq_bind($$bind_ref1, $$bind_ref2);
+ } elsif ($ref1 eq 'ARRAY') {
+ return 0 if scalar @$bind_ref1 != scalar @$bind_ref2;
+ for (my $i = 0; $i < @$bind_ref1; $i++) {
+ return 0 if !eq_bind($bind_ref1->[$i], $bind_ref2->[$i]);
+ }
+ return 1;
+ } elsif ($ref1 eq 'HASH') {
+ return
+ eq_bind(
+ [sort keys %$bind_ref1],
+ [sort keys %$bind_ref2]
+ )
+ && eq_bind(
+ [map { $bind_ref1->{$_} } sort keys %$bind_ref1],
+ [map { $bind_ref2->{$_} } sort keys %$bind_ref2]
+ );
+ } else {
+ if (!defined $bind_ref1 || !defined $bind_ref2) {
+ return !(defined $bind_ref1 ^ defined $bind_ref2);
+ } elsif (blessed($bind_ref1) || blessed($bind_ref2)) {
+ return 0 if (blessed($bind_ref1) || "") ne (blessed($bind_ref2) || "");
+ return 1 if $bind_ref1 == $bind_ref2; # uses overloaded '=='
+ # fallback: compare the guts of the object
+ my $reftype1 = reftype $bind_ref1;
+ my $reftype2 = reftype $bind_ref2;
+ return 0 if $reftype1 ne $reftype2;
+ if ($reftype1 eq 'SCALAR' || $reftype1 eq 'REF') {
+ $bind_ref1 = $$bind_ref1;
+ $bind_ref2 = $$bind_ref2;
+ } elsif ($reftype1 eq 'ARRAY') {
+ $bind_ref1 = [@$bind_ref1];
+ $bind_ref2 = [@$bind_ref2];
+ } elsif ($reftype1 eq 'HASH') {
+ $bind_ref1 = {%$bind_ref1};
+ $bind_ref2 = {%$bind_ref2};
+ } else {
+ return 0;
+ }
+ return eq_bind($bind_ref1, $bind_ref2);
+ } elsif (looks_like_number($bind_ref1) && looks_like_number($bind_ref2)) {
+ return $bind_ref1 == $bind_ref2;
+ } else {
+ return $bind_ref1 eq $bind_ref2;
+ }
+ }
}
sub eq_sql {
Added: SQL-Abstract/1.x/branches/1.50_RC/t/10test.t
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC/t/10test.t (rev 0)
+++ SQL-Abstract/1.x/branches/1.50_RC/t/10test.t 2008-11-26 22:35:33 UTC (rev 5215)
@@ -0,0 +1,229 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use List::Util qw(sum);
+use Data::Dumper;
+
+use Test::More;
+
+
+my @bind_tests = (
+ # scalar - equal
+ {
+ equal => 1,
+ bindvals => [
+ undef,
+ undef,
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 'foo',
+ 'foo',
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 42,
+ 42,
+ '42',
+ ]
+ },
+
+ # scalarref - equal
+ {
+ equal => 1,
+ bindvals => [
+ \'foo',
+ \'foo',
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ \42,
+ \42,
+ \'42',
+ ]
+ },
+
+ # arrayref - equal
+ {
+ equal => 1,
+ bindvals => [
+ [],
+ []
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ [42],
+ [42],
+ ['42'],
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ [1, 42],
+ [1, 42],
+ ['1', 42],
+ [1, '42'],
+ ['1', '42'],
+ ]
+ },
+
+ # hashref - equal
+ {
+ equal => 1,
+ bindvals => [
+ { foo => 42 },
+ { foo => 42 },
+ { foo => '42' },
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ { foo => 42, bar => 1 },
+ { foo => 42, bar => 1 },
+ { foo => '42', bar => 1 },
+ ]
+ },
+
+ # blessed object - equal
+ {
+ equal => 1,
+ bindvals => [
+ bless(\(local $_ = 42), 'Life::Universe::Everything'),
+ bless(\(local $_ = 42), 'Life::Universe::Everything'),
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ bless([42], 'Life::Universe::Everything'),
+ bless([42], 'Life::Universe::Everything'),
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ bless({ answer => 42 }, 'Life::Universe::Everything'),
+ bless({ answer => 42 }, 'Life::Universe::Everything'),
+ ]
+ },
+
+ # complex data structure - equal
+ {
+ equal => 1,
+ bindvals => [
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ ]
+ },
+
+
+ # scalar - different
+ {
+ equal => 0,
+ bindvals => [
+ undef,
+ 'foo',
+ 42,
+ ]
+ },
+
+ # scalarref - different
+ {
+ equal => 0,
+ bindvals => [
+ \undef,
+ \'foo',
+ \42,
+ ]
+ },
+
+ # arrayref - different
+ {
+ equal => 0,
+ bindvals => [
+ [undef],
+ ['foo'],
+ [42],
+ ]
+ },
+
+ # hashref - different
+ {
+ equal => 0,
+ bindvals => [
+ { foo => undef },
+ { foo => 'bar' },
+ { foo => 42 },
+ ]
+ },
+
+ # different types
+ {
+ equal => 0,
+ bindvals => [
+ 'foo',
+ \'foo',
+ ['foo'],
+ { foo => 'bar' },
+ ]
+ },
+
+ # complex data structure - different
+ {
+ equal => 0,
+ bindvals => [
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [43, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'baz', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { bar => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quuux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [0, 1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, 3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \4, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quuux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5, 6] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => 4 } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5], quuux => 1 } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8, 9 ],
+ ]
+ },
+);
+
+
+plan tests => 1 + sum
+ map { $_ * ($_ - 1) / 2 }
+ map { scalar @{$_->{bindvals}} }
+ @bind_tests;
+
+use_ok('SQL::Abstract::Test', import => [qw(eq_sql eq_bind is_same_sql_bind)]);
+
+for my $test (@bind_tests) {
+ my $bindvals = $test->{bindvals};
+ while (@$bindvals) {
+ my $bind1 = shift @$bindvals;
+ foreach my $bind2 (@$bindvals) {
+ my $equal = eq_bind($bind1, $bind2);
+ if ($test->{equal}) {
+ ok($equal, "equal bind values considered equal");
+ } else {
+ ok(!$equal, "different bind values considered not equal");
+ }
+
+ if ($equal ^ $test->{equal}) {
+ diag("bind1: " . Dumper($bind1));
+ diag("bind2: " . Dumper($bind2));
+ }
+ }
+ }
+}
More information about the Bast-commits
mailing list