X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract%2FTest.pm;h=8a455e255790f0121a1d37b31cf42d9325e6c23c;hb=d5b7788a4027ca20b3e7fb1f2b4ba50ee619d2cd;hp=c802be16fa08b7c59ac5b2b36c701d3083c88140;hpb=b343752666c091274fe82eedeadcc39e64a7816c;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index c802be1..8a455e2 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -2,15 +2,23 @@ package SQL::Abstract::Test; # see doc at end of file use strict; use warnings; -use base qw/Test::Builder::Module Exporter/; -use Data::Dumper; +use base qw(Test::Builder::Module Exporter); use Test::Builder; use Test::Deep (); use SQL::Abstract::Tree; -our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind - &eq_sql_bind &eq_sql &eq_bind - $case_sensitive $sql_differ/; +if (my $class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) { + my $mod = join('/', split '::', $class).".pm"; + require $mod; + eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1} + or die "Failed to create const sub for ${class}: $@"; +} + +our @EXPORT_OK = qw( + is_same_sql_bind is_same_sql is_same_bind + eq_sql_bind eq_sql eq_bind dumper diag_where + $case_sensitive $sql_differ +); my $sqlat = SQL::Abstract::Tree->new; @@ -21,8 +29,30 @@ our $order_by_asc_significant = 0; our $sql_differ; # keeps track of differing portion between SQLs our $tb = __PACKAGE__->builder; +sub _unpack_arrayrefref { + + my @args; + for (1,2) { + my $chunk = shift @_; + + if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') { + my ($sql, @bind) = @$$chunk; + push @args, ($sql, \@bind); + } + else { + push @args, $chunk, shift @_; + } + + } + + # maybe $msg and ... stuff + push @args, @_; + + @args; +} + sub is_same_sql_bind { - my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; + my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref; # compare my $same_sql = eq_sql($sql1, $sql2); @@ -47,7 +77,7 @@ sub is_same_sql { my ($sql1, $sql2, $msg) = @_; # compare - my $same_sql = eq_sql($sql1, $sql2); + my $same_sql = eq_sql($sql1, $sql2); # call Test::Builder::ok my $ret = $tb->ok($same_sql, $msg); @@ -79,31 +109,46 @@ sub is_same_bind { return $ret; } +sub dumper { + # FIXME + # if we save the instance, we will end up with $VARx references + # no time to figure out how to avoid this (Deepcopy is *not* an option) + require Data::Dumper; + Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0) + ->Values([@_])->Dump; +} + +sub diag_where{ + $tb->diag("Search term:\n" . &dumper); +} + sub _sql_differ_diag { - my ($sql1, $sql2) = @_; + my $sql1 = shift || ''; + my $sql2 = shift || ''; - $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( + if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) { + my $sqlat = SQL::Abstract::Tree->new(profile => $profile); + $_ = $sqlat->format($_) for ($sql1, $sql2); + } + + $tb->${\($tb->in_todo ? 'note' : 'diag')} ( "SQL expressions differ\n" - ." got: $sql1\n" - ."expected: $sql2\n" - ."differing in :\n$sql_differ\n" + ." got: $sql1\n" + ."want: $sql2\n" + ."\nmismatch around\n$sql_differ\n" ); } sub _bind_differ_diag { my ($bind_ref1, $bind_ref2) = @_; - local $Data::Dumper::Maxdepth; - - $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( - "BIND values differ\n" - ." got: " . Dumper($bind_ref1) - ."expected: " . Dumper($bind_ref2) - ); + $tb->${\($tb->in_todo ? 'note' : 'diag')} ( + "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 }) + ); } sub eq_sql_bind { - my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; + my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref; return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); } @@ -126,8 +171,8 @@ sub _eq_sql { my ($left, $right) = @_; # one is defined the other not - if ( (defined $left) xor (defined $right) ) { - $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) ); + if ((defined $left) xor (defined $right)) { + $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) ); return 0; } @@ -143,14 +188,14 @@ sub _eq_sql { # one is empty if (@$left == 0 or @$right == 0) { - $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) ); + $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) ); return 0; } # one is a list, the other is an op with a list elsif (ref $left->[0] xor ref $right->[0]) { $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map - { ref $_ ? $sqlat->unparse ($_) : $_ } + { ref $_ ? $sqlat->unparse($_) : $_ } ($left->[0], $right->[0], $left, $right) ); return 0; @@ -163,7 +208,7 @@ sub _eq_sql { if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { $sql_differ ||= ''; $sql_differ .= "\n" unless $sql_differ =~ /\n\z/; - $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); + $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ); } return 0; } @@ -175,7 +220,7 @@ sub _eq_sql { else { # unroll parenthesis if possible/allowed - unless ( $parenthesis_significant ) { + unless ($parenthesis_significant) { $sqlat->_parenthesis_unroll($_) for $left, $right; } @@ -184,7 +229,7 @@ sub _eq_sql { $sqlat->_strip_asc_from_order_by($_) for $left, $right; } - if ( $left->[0] ne $right->[0] ) { + if ($left->[0] ne $right->[0]) { $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", $sqlat->unparse($left), $sqlat->unparse($right) @@ -204,7 +249,7 @@ sub _eq_sql { # if operators are identical, compare operands else { my $eq = _eq_sql($left->[1], $right->[1]); - $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq; + $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq; return $eq; } } @@ -259,52 +304,83 @@ B : the semantic equivalence handling is pretty limited. A lot of effort goes into distinguishing significant from non-significant parenthesis, including AND/OR operator associativity. Currently this module does not support commutativity and more -intelligent transformations like Morgan laws, etc. +intelligent transformations like L, etc. -For a good overview of what this test framework is capable of refer +For a good overview of what this test framework is currently capable of refer to C =head1 FUNCTIONS =head2 is_same_sql_bind - is_same_sql_bind($given_sql, \@given_bind, - $expected_sql, \@expected_bind, $test_msg); + is_same_sql_bind( + $given_sql, \@given_bind, + $expected_sql, \@expected_bind, + $test_msg + ); -Compares given and expected pairs of C<($sql, \@bind)>, and calls -L on the result, with C<$test_msg> as message. If the test -fails, a detailed diagnostic is printed. For clients which use L, -this is the one of the three functions (L, L, -L) that needs to be imported. + is_same_sql_bind( + \[$given_sql, @given_bind], + \[$expected_sql, @expected_bind], + $test_msg + ); + + is_same_sql_bind( + $dbic_rs->as_query + $expected_sql, \@expected_bind, + $test_msg + ); + +Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_> +as shown in the examples above and passing the arguments to L and +L. Calls L with the combined result, with +C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. =head2 is_same_sql - is_same_sql($given_sql, $expected_sql, $test_msg); + is_same_sql( + $given_sql, + $expected_sql, + $test_msg + ); -Compares given and expected SQL statements, and calls L on -the result, with C<$test_msg> as message. If the test fails, a detailed -diagnostic is printed. For clients which use L, this is the one of -the three functions (L, L, L) -that needs to be imported. +Compares given and expected SQL statements via L, and calls +L on the result, with C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. =head2 is_same_bind - is_same_bind(\@given_bind, \@expected_bind, $test_msg); + is_same_bind( + \@given_bind, + \@expected_bind, + $test_msg + ); -Compares given and expected bind values, and calls L on the -result, with C<$test_msg> as message. If the test fails, a detailed diagnostic -is printed. For clients which use L, this is the one of the three -functions (L, L, L) that needs -to be imported. +Compares given and expected bind values via L, and calls +L on the result, with C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. =head2 eq_sql_bind - my $is_same = eq_sql_bind($given_sql, \@given_bind, - $expected_sql, \@expected_bind); + my $is_same = eq_sql_bind( + $given_sql, \@given_bind, + $expected_sql, \@expected_bind, + ); -Compares given and expected pairs of C<($sql, \@bind)>. Similar to -L, but it just returns a boolean value and does not print -diagnostics or talk to L. + my $is_same = eq_sql_bind( + \[$given_sql, @given_bind], + \[$expected_sql, @expected_bind], + ); + + my $is_same = eq_sql_bind( + $dbic_rs->as_query + $expected_sql, \@expected_bind, + ); + +Unpacks C<@_> depending on the given arguments and calls L and +L, returning their combined result. =head2 eq_sql @@ -348,14 +424,13 @@ When L returns false, the global variable C<$sql_differ> contains the SQL portion where a difference was encountered. - =head1 SEE ALSO L, L, L. =head1 AUTHORS -Laurent Dami, Elaurent.dami AT etat geneve chE +Laurent Dami Norbert Buchmuller