X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract%2FTest.pm;h=564a84332bf09410a2b74c597176d1136f242071;hb=1a828f61e5c85cb650c591fb3e4c12e8db15e845;hp=4153add0f6c16e6c407527bd4643a74cf328341f;hpb=4abea32b11d885ad9a7b9617e50e38c8be39b78f;p=scpubgit%2FQ-Branch.git diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index 4153add..564a843 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -3,47 +3,153 @@ package SQL::Abstract::Test; # see doc at end of file 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 Test::Builder; use Test::Deep qw(eq_deeply); -our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind +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/; our $case_sensitive = 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; +use constant PARSE_IN_EXPR => 1; +use constant 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', +); + +my $tokenizer_re_str = join('|', + map { '\b' . $_ . '\b' } + @expression_terminator_sql_keywords, 'AND', 'OR' +); + +my $tokenizer_re = qr/ + \s* + ( + \( + | + \) + | + $tokenizer_re_str + ) + \s* +/xi; + + sub is_same_sql_bind { my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; # compare - my $tree1 = parse($sql1); - my $tree2 = parse($sql2); - my $same_sql = eq_sql($tree1, $tree2); + 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 _sql_differ_diag { + my ($sql1, $sql2) = @_; + + $tb->diag("SQL expressions differ\n" + ." got: $sql1\n" + ."expected: $sql2\n" + ."differing in :\n$sql_differ\n" + ); +} + +sub _bind_differ_diag { + my ($bind_ref1, $bind_ref2) = @_; + + $tb->diag("BIND values differ\n" + ." got: " . Dumper($bind_ref1) + ."expected: " . Dumper($bind_ref2) + ); +} + +sub eq_sql_bind { + my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; + + return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); } + sub eq_bind { my ($bind_ref1, $bind_ref2) = @_; @@ -51,14 +157,32 @@ sub eq_bind { } sub eq_sql { + my ($sql1, $sql2) = @_; + + # parse + my $tree1 = parse($sql1); + my $tree2 = parse($sql2); + + return _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]} + while ($left and $left->[0] and $left->[0] eq 'PAREN') {$left = $left->[1]} + while ($right and $right->[0] and $right->[0] eq 'PAREN') {$right = $right->[1]} + # one is defined the other not + if ( (defined $left) xor (defined $right) ) { + return 0; + } + # one is undefined, then so is the other + elsif (not defined $left) { + return 1; + } # if operators are different - if ($left->[0] ne $right->[0]) { + elsif ($left->[0] ne $right->[0]) { $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", unparse($left), unparse($right); @@ -74,8 +198,8 @@ sub eq_sql { 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 + return _eq_sql($left->[1][0], $right->[1][0]) # left operand + && _eq_sql($left->[1][1], $right->[1][1]); # right operand } } } @@ -84,27 +208,37 @@ sub eq_sql { sub parse { my $s = shift; - # tokenize string - my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; + # 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 !~ /^$/; + } - my $tree = _recurse_parse($tokens); + my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL); return $tree; } sub _recurse_parse { - my $tokens = shift; + my ($tokens, $state) = @_; my $left; while (1) { # left-associative parsing my $lookahead = $tokens->[0]; - return $left if !defined($lookahead) || $lookahead eq ')'; + return $left if !defined($lookahead) + || ($state == PARSE_IN_PARENS && $lookahead eq ')') + || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi } + '\)', @expression_terminator_sql_keywords + ); my $token = shift @$tokens; # nested expression in () if ($token eq '(') { - my $right = _recurse_parse($tokens); + 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]]] @@ -112,9 +246,15 @@ sub _recurse_parse { } # AND/OR elsif ($token eq 'AND' || $token eq 'OR') { - my $right = _recurse_parse($tokens); + my $right = _recurse_parse($tokens, PARSE_IN_EXPR); $left = [$token => [$left, $right]]; } + # 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]]]; + } # leaf expression else { $left = $left ? [CONCAT => [$left, [EXPR => $token]]] @@ -151,12 +291,25 @@ SQL::Abstract::Test - Helper function for testing SQL::Abstract 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, $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 @@ -182,34 +335,66 @@ laws, etc. $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 only function that needs to be -imported. +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. + +=head2 is_same_sql + + 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. + +=head2 is_same_bind + + 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. + +=head2 eq_sql_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. =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 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, +but it just returns a boolean value and does not print diagnostics or talk to +L. If the result is false, the global variable L +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). +Compares two lists of bind values, taking into account the fact that some of +the values may be arrayrefs (see L). Similar to +L, but it just returns a boolean value and does not print +diagnostics or talk to L. =head1 GLOBAL VARIABLES -=head2 case_sensitive +=head2 $case_sensitive If true, SQL comparisons will be case-sensitive. Default is false; -=head2 sql_differ +=head2 $sql_differ When L returns false, the global variable C<$sql_differ> contains the SQL portion @@ -220,10 +405,12 @@ where a difference was encountered. L, L, L. -=head1 AUTHOR +=head1 AUTHORS Laurent Dami, Elaurent.dami AT etat geneve chE +Norbert Buchmuller + =head1 COPYRIGHT AND LICENSE Copyright 2008 by Laurent Dami.