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;
+use base qw(Test::Builder::Module Exporter);
use Test::Builder;
-use Test::Deep qw(eq_deeply);
+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 &eq_sql &eq_bind
- $case_sensitive $sql_differ/;
+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 = __PACKAGE__->builder;
-# Parser states for _recurse_parse()
-use constant {
- PARSE_TOP_LEVEL => 0,
- PARSE_IN_EXPR => 1,
- PARSE_IN_PARENS => 2,
-};
-
-# These SQL keywords always signal end of the current expression (except inside
-# of a parenthesized subexpression).
-# Format: A list of strings that will be compiled to extended syntax (ie.
-# /.../x) regexes, without capturing parentheses. They will be automatically
-# anchored to word boundaries to match the whole token).
-my @expression_terminator_sql_keywords = (
- 'FROM',
- '(?:
- (?:
- (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
- (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
- )?
- JOIN
- )',
- 'ON',
- 'WHERE',
- 'GROUP \s+ BY',
- 'HAVING',
- 'ORDER \s+ BY',
- 'LIMIT',
- 'OFFSET',
- 'FOR',
- 'UNION',
- 'INTERSECT',
- 'EXCEPT',
-);
+sub _unpack_arrayrefref {
-my $tokenizer_re_str = join('|',
- map { '\b' . $_ . '\b' }
- @expression_terminator_sql_keywords, 'AND', 'OR'
-);
+ 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 @_;
+ }
-my $tokenizer_re = qr/
- \s*
- (
- \(
- |
- \)
- |
- $tokenizer_re_str
- )
- \s*
-/xi;
+ }
+
+ # 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);
my $same_bind = eq_bind($bind_ref1, $bind_ref2);
# call Test::Builder::ok
- $tb->ok($same_sql && $same_bind, $msg);
+ 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 $ret = $tb->ok($same_sql, $msg);
# add debugging info
if (!$same_sql) {
- $tb->diag("SQL expressions differ\n"
- ." got: $sql1\n"
- ."expected: $sql2\n"
- ."differing in :\n$sql_differ\n"
- );
+ _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 $ret = $tb->ok($same_bind, $msg);
+
+ # add debugging info
if (!$same_bind) {
- $tb->diag("BIND values differ\n"
- ." got: " . Dumper($bind_ref1)
- ."expected: " . Dumper($bind_ref2)
- );
+ _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{
+ $tb->diag("Search term:\n" . &dumper);
+}
+
+sub _sql_differ_diag {
+ my $sql1 = shift || '';
+ my $sql2 = shift || '';
+
+ 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 eq_bind {
+sub _bind_differ_diag {
my ($bind_ref1, $bind_ref2) = @_;
- return eq_deeply($bind_ref1, $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) = &_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 = parse($sql1);
- my $tree2 = parse($sql2);
+ my $tree1 = $sqlat->parse($sql1);
+ my $tree2 = $sqlat->parse($sql2);
- return _eq_sql($tree1, $tree2);
+ undef $sql_differ;
+ return 1 if _eq_sql($tree1, $tree2);
}
sub _eq_sql {
my ($left, $right) = @_;
- # ignore top-level parentheses
- while ($left->[0] eq 'PAREN') {$left = $left->[1] }
- while ($right->[0] eq 'PAREN') {$right = $right->[1]}
-
- # if operators are different
- if ($left->[0] ne $right->[0]) {
- $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
- unparse($left),
- unparse($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;
}
- # elsif operators are identical, compare operands
- else {
- if ($left->[0] eq 'EXPR' ) { # unary operator
- (my $l = " $left->[1] " ) =~ s/\s+/ /g;
- (my $r = " $right->[1] ") =~ s/\s+/ /g;
- my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
- $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
- return $eq;
- }
- else { # binary operator
- return _eq_sql($left->[1][0], $right->[1][0]) # left operand
- && _eq_sql($left->[1][1], $right->[1][1]); # right operand
- }
- }
-}
+ # one is undefined, then so is the other
+ elsif (not defined $left) {
+ return 1;
+ }
-sub parse {
- my $s = shift;
-
- # tokenize string, and remove all optional whitespace
- my $tokens = [];
- foreach my $token (split $tokenizer_re, $s) {
- $token =~ s/\s+/ /g;
- $token =~ s/\s+([^\w\s])/$1/g;
- $token =~ s/([^\w\s])\s+/$1/g;
- push @$tokens, $token if $token !~ /^$/;
+ # both are empty
+ elsif (@$left == 0 and @$right == 0) {
+ return 1;
}
- my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
- return $tree;
-}
+ # 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;
+ }
-sub _recurse_parse {
- my ($tokens, $state) = @_;
+ # 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;
+ }
- my $left;
- while (1) { # left-associative parsing
+ # 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;
+ }
- my $lookahead = $tokens->[0];
- return $left if !defined($lookahead)
- || ($state == PARSE_IN_PARENS && $lookahead eq ')')
- || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
- '\)', @expression_terminator_sql_keywords
- );
+ # both are ops
+ else {
- my $token = shift @$tokens;
+ # unroll parenthesis if possible/allowed
+ unless ($parenthesis_significant) {
+ $sqlat->_parenthesis_unroll($_) for $left, $right;
+ }
- # nested expression in ()
- if ($token eq '(') {
- my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
- $token = shift @$tokens or croak "missing ')'";
- $token eq ')' or croak "unexpected token : $token";
- $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
- : [PAREN => $right];
+ # unroll ASC order by's
+ unless ($order_by_asc_significant) {
+ $sqlat->_strip_asc_from_order_by($_) for $left, $right;
}
- # AND/OR
- elsif ($token eq 'AND' || $token eq 'OR') {
- my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
- $left = [$token => [$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;
}
- # expression terminator keywords (as they start a new expression)
- elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
- my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
- $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
- : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
+
+ # 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;
}
- # leaf expression
+
+ # if operators are identical, compare operands
else {
- $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
- : [EXPR => $token];
+ 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 unparse {
- my $tree = shift;
- my $dispatch = {
- EXPR => sub {$tree->[1] },
- PAREN => sub {"(" . unparse($tree->[1]) . ")" },
- CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
- AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
- OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
- };
- $dispatch->{$tree->[0]}->();
-}
-
-
+sub parse { $sqlat->parse(@_) }
1;
use SQL::Abstract;
use Test::More;
- use SQL::Abstract::Test import => ['is_same_sql_bind'];
-
+ 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,
+
+ 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
Therefore the tests will pass as long as the semantics
is preserved, even if the surface syntax has changed.
-B<Disclaimer> : this is only a half-cooked semantic equivalence;
-parsing is simple-minded, and comparison of SQL abstract syntax trees
-ignores commutativity or associativity of AND/OR operators, Morgan
-laws, etc.
+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);
-
-Compares given and expected pairs of C<($sql, \@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. For clients which use
-L<Test::Build>, this is the only function that needs to be
-imported.
+ 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. If the result is
-false, global variable L</sql_differ> will contain the SQL portion
-where a difference was encountered; this is useful for printing diagnostics.
+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>).
+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
+=head2 $case_sensitive
If true, SQL comparisons will be case-sensitive. Default is false;
-=head2 sql_differ
+=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, E<lt>laurent.dami AT etat geneve chE<gt>
+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.
+it under the same terms as Perl itself.