481 lines
12 KiB
Perl
481 lines
12 KiB
Perl
package SQL::Abstract::Test; # see doc at end of file
|
|
|
|
use strict;
|
|
use warnings;
|
|
use base qw(Test::Builder::Module);
|
|
use Test::Builder;
|
|
use Test::Deep ();
|
|
use SQL::Abstract::Tree;
|
|
|
|
{
|
|
my $class;
|
|
if ($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}: $@";
|
|
}
|
|
if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) {
|
|
$class ||= do { require SQL::Abstract; 'SQL::Abstract' };
|
|
my $orig = $class->can('expand_expr');
|
|
require Data::Dumper::Concise;
|
|
my $wrapped = sub {
|
|
my ($self, @args) = @_;
|
|
my $e1 = $self->$orig(@args);
|
|
return $e1 if our $Stab_Check_Rec;
|
|
local $Stab_Check_Rec = 1;
|
|
my $e2 = $self->$orig($e1);
|
|
my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2;
|
|
(our $tb)->is_eq(
|
|
$d2, $d1,
|
|
'expand_expr stability ok'
|
|
) or do {
|
|
require Path::Tiny;
|
|
Path::Tiny->new('e1')->spew($d1);
|
|
Path::Tiny->new('e2')->spew($d2);
|
|
system('diff -u e1 e2 1>&2');
|
|
die "Differences between e1 and e2, bailing out";
|
|
};
|
|
return $e1;
|
|
};
|
|
no strict 'refs'; no warnings 'redefine';
|
|
*{"${class}::expand_expr"} = $wrapped;
|
|
}
|
|
}
|
|
|
|
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;
|
|
|
|
our $case_sensitive = 0;
|
|
our $parenthesis_significant = 0;
|
|
our $order_by_asc_significant = 0;
|
|
|
|
our $sql_differ; # keeps track of differing portion between SQLs
|
|
our $tb; # not documented, but someone might be overriding it anyway
|
|
|
|
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) = &_unpack_arrayrefref;
|
|
|
|
# compare
|
|
my $same_sql = eq_sql($sql1, $sql2);
|
|
my $same_bind = eq_bind($bind_ref1, $bind_ref2);
|
|
|
|
# call Test::Builder::ok
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
my $ret = $tb->ok($same_sql && $same_bind, $msg);
|
|
|
|
# add debugging info
|
|
if (!$same_sql) {
|
|
_sql_differ_diag($sql1, $sql2);
|
|
}
|
|
if (!$same_bind) {
|
|
_bind_differ_diag($bind_ref1, $bind_ref2);
|
|
}
|
|
|
|
# pass ok() result further
|
|
return $ret;
|
|
}
|
|
|
|
sub is_same_sql {
|
|
my ($sql1, $sql2, $msg) = @_;
|
|
|
|
# compare
|
|
my $same_sql = eq_sql($sql1, $sql2);
|
|
|
|
# call Test::Builder::ok
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
my $ret = $tb->ok($same_sql, $msg);
|
|
|
|
# add debugging info
|
|
if (!$same_sql) {
|
|
_sql_differ_diag($sql1, $sql2);
|
|
}
|
|
|
|
# pass ok() result further
|
|
return $ret;
|
|
}
|
|
|
|
sub is_same_bind {
|
|
my ($bind_ref1, $bind_ref2, $msg) = @_;
|
|
|
|
# compare
|
|
my $same_bind = eq_bind($bind_ref1, $bind_ref2);
|
|
|
|
# call Test::Builder::ok
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
my $ret = $tb->ok($same_bind, $msg);
|
|
|
|
# add debugging info
|
|
if (!$same_bind) {
|
|
_bind_differ_diag($bind_ref1, $bind_ref2);
|
|
}
|
|
|
|
# pass ok() result further
|
|
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{
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
$tb->diag("Search term:\n" . &dumper);
|
|
}
|
|
|
|
sub _sql_differ_diag {
|
|
my $sql1 = shift || '';
|
|
my $sql2 = shift || '';
|
|
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
|
|
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"
|
|
."want: $sql2\n"
|
|
."\nmismatch around\n$sql_differ\n"
|
|
);
|
|
}
|
|
|
|
sub _bind_differ_diag {
|
|
my ($bind_ref1, $bind_ref2) = @_;
|
|
|
|
my $tb = $tb || __PACKAGE__->builder;
|
|
$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) = &_unpack_arrayrefref;
|
|
|
|
return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
|
|
}
|
|
|
|
|
|
sub eq_bind { goto &Test::Deep::eq_deeply };
|
|
|
|
sub eq_sql {
|
|
my ($sql1, $sql2) = @_;
|
|
|
|
# parse
|
|
my $tree1 = $sqlat->parse($sql1);
|
|
my $tree2 = $sqlat->parse($sql2);
|
|
|
|
undef $sql_differ;
|
|
return 1 if _eq_sql($tree1, $tree2);
|
|
}
|
|
|
|
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) );
|
|
return 0;
|
|
}
|
|
|
|
# one is undefined, then so is the other
|
|
elsif (not defined $left) {
|
|
return 1;
|
|
}
|
|
|
|
# both are empty
|
|
elsif (@$left == 0 and @$right == 0) {
|
|
return 1;
|
|
}
|
|
|
|
# one is empty
|
|
if (@$left == 0 or @$right == 0) {
|
|
$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($_) : $_ }
|
|
($left->[0], $right->[0], $left, $right)
|
|
);
|
|
return 0;
|
|
}
|
|
|
|
# both are lists
|
|
elsif (ref $left->[0]) {
|
|
for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
|
|
if (not _eq_sql ($left->[$i], $right->[$i]) ) {
|
|
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) );
|
|
}
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# both are ops
|
|
else {
|
|
|
|
# unroll parenthesis if possible/allowed
|
|
unless ($parenthesis_significant) {
|
|
$sqlat->_parenthesis_unroll($_) for $left, $right;
|
|
}
|
|
|
|
# unroll ASC order by's
|
|
unless ($order_by_asc_significant) {
|
|
$sqlat->_strip_asc_from_order_by($_) for $left, $right;
|
|
}
|
|
|
|
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)
|
|
;
|
|
return 0;
|
|
}
|
|
|
|
# literals have a different arg-sig
|
|
elsif ($left->[0] eq '-LITERAL') {
|
|
(my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
|
|
(my $r = " $right->[1][0] ") =~ s/\s+/ /g;
|
|
my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
|
|
$sql_differ = "[$l] != [$r]\n" if not $eq;
|
|
return $eq;
|
|
}
|
|
|
|
# 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;
|
|
return $eq;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub parse { $sqlat->parse(@_) }
|
|
1;
|
|
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
SQL::Abstract::Test - Helper function for testing SQL::Abstract
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use SQL::Abstract;
|
|
use Test::More;
|
|
use SQL::Abstract::Test import => [qw/
|
|
is_same_sql_bind is_same_sql is_same_bind
|
|
eq_sql_bind eq_sql eq_bind
|
|
/];
|
|
|
|
my ($sql, @bind) = SQL::Abstract->new->select(%args);
|
|
|
|
is_same_sql_bind($given_sql, \@given_bind,
|
|
$expected_sql, \@expected_bind, $test_msg);
|
|
|
|
is_same_sql($given_sql, $expected_sql, $test_msg);
|
|
is_same_bind(\@given_bind, \@expected_bind, $test_msg);
|
|
|
|
my $is_same = eq_sql_bind($given_sql, \@given_bind,
|
|
$expected_sql, \@expected_bind);
|
|
|
|
my $sql_same = eq_sql($given_sql, $expected_sql);
|
|
my $bind_same = eq_bind(\@given_bind, \@expected_bind);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module is only intended for authors of tests on
|
|
L<SQL::Abstract|SQL::Abstract> and related modules;
|
|
it exports functions for comparing two SQL statements
|
|
and their bound values.
|
|
|
|
The SQL comparison is performed on I<abstract syntax>,
|
|
ignoring differences in spaces or in levels of parentheses.
|
|
Therefore the tests will pass as long as the semantics
|
|
is preserved, even if the surface syntax has changed.
|
|
|
|
B<Disclaimer> : 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 L<De Morgan's laws
|
|
|http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
|
|
|
|
For a good overview of what this test framework is currently capable of refer
|
|
to C<t/10test.t>
|
|
|
|
=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
|
|
);
|
|
|
|
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</eq_sql> and
|
|
L</eq_bind>. Calls L<Test::Builder/ok> 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
|
|
);
|
|
|
|
Compares given and expected SQL statements via L</eq_sql>, and calls
|
|
L<Test::Builder/ok> 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
|
|
);
|
|
|
|
Compares given and expected bind values via L</eq_bind>, and calls
|
|
L<Test::Builder/ok> 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],
|
|
);
|
|
|
|
my $is_same = eq_sql_bind(
|
|
$dbic_rs->as_query
|
|
$expected_sql, \@expected_bind,
|
|
);
|
|
|
|
Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
|
|
L</eq_bind>, returning their combined result.
|
|
|
|
=head2 eq_sql
|
|
|
|
my $is_same = eq_sql($given_sql, $expected_sql);
|
|
|
|
Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
|
|
but it just returns a boolean value and does not print diagnostics or talk to
|
|
L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
|
|
will contain the SQL portion where a difference was encountered; this is useful
|
|
for printing diagnostics.
|
|
|
|
=head2 eq_bind
|
|
|
|
my $is_same = eq_sql(\@given_bind, \@expected_bind);
|
|
|
|
Compares two lists of bind values, taking into account the fact that some of
|
|
the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
|
|
L</is_same_bind>, but it just returns a boolean value and does not print
|
|
diagnostics or talk to L<Test::Builder>.
|
|
|
|
=head1 GLOBAL VARIABLES
|
|
|
|
=head2 $case_sensitive
|
|
|
|
If true, SQL comparisons will be case-sensitive. Default is false;
|
|
|
|
=head2 $parenthesis_significant
|
|
|
|
If true, SQL comparison will preserve and report difference in nested
|
|
parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
|
|
Defaults to false;
|
|
|
|
=head2 $order_by_asc_significant
|
|
|
|
If true SQL comparison will consider C<ORDER BY foo ASC> and
|
|
C<ORDER BY foo> to be different. Default is false;
|
|
|
|
=head2 $sql_differ
|
|
|
|
When L</eq_sql> returns false, the global variable
|
|
C<$sql_differ> contains the SQL portion
|
|
where a difference was encountered.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
|
|
|
|
=head1 AUTHORS
|
|
|
|
Laurent Dami <laurent.dami AT etat geneve ch>
|
|
|
|
Norbert Buchmuller <norbi@nix.hu>
|
|
|
|
Peter Rabbitson <ribasushi@cpan.org>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright 2008 by Laurent Dami.
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself.
|