From: Laurent Dami Date: Thu, 6 Nov 2008 02:23:31 +0000 (+0000) Subject: patch by Norbert BUCHMULLER: arguments to 'where' that are blessed objects with a... X-Git-Tag: v1.70~269 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fffe6900cc1ab24696c060ecfa36d626e84b8bbf;p=dbsrgits%2FSQL-Abstract.git patch by Norbert BUCHMULLER: arguments to 'where' that are blessed objects with a stringification method are treated like scalars. --- diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index f7c93f1..8fadec4 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -8,7 +8,8 @@ package SQL::Abstract; # see doc at end of file use Carp; use strict; use warnings; -use List::Util qw/first/; +use List::Util qw/first/; +use Scalar::Util qw/blessed/; #====================================================================== # GLOBALS @@ -707,6 +708,7 @@ sub _order_by { ARRAYREF => sub { map {$self->_SWITCH_refkind($_, { SCALAR => sub {$self->_quote($_)}, + UNDEF => sub {}, SCALARREF => sub {$$_}, # literal SQL, no quoting HASHREF => sub {$self->_order_by_hash($_)} }) } @$arg; @@ -867,7 +869,10 @@ sub _refkind { # $suffix = 'REF' x (length of ref chain, i. e. \\[] is REFREFREF) while (1) { $suffix .= 'REF'; - $ref = ref $data; + + # blessed references that can stringify are considered like scalars + $ref = (blessed $data && overload::Method($data, '""')) ? '' + : ref $data; last if $ref ne 'REF'; $data = $$data; } diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index e4b4d22..916ad6d 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -1,240 +1,241 @@ -package SQL::Abstract::Test; # see doc at end of file - -use strict; -use warnings; -use Test::More; -use base 'Exporter'; -use Data::Dumper; -use Carp; - -our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind - $case_sensitive $sql_differ/; - -our $case_sensitive = 0; -our $sql_differ; # keeps track of differing portion between SQLs - -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_bind = eq_bind($bind_ref1, $bind_ref2); - - # call Test::More::ok - ok($same_sql && $same_bind, $msg); - - # add debugging info - if (!$same_sql) { - diag "SQL expressions differ\n" - ." got: $sql1\n" - ."expected: $sql2\n" - ."differing in :\n$sql_differ\n"; - ; - } - if (!$same_bind) { - diag "BIND values differ\n" - ." got: " . Dumper($bind_ref1) - ."expected: " . Dumper($bind_ref2) - ; - } -} - - -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 || []; - - # some bind values can be arrayrefs (see L), - # so stringify them. - my @strings = map {ref $_ ? join('=>', @$_) : ($_ || '')} @$bind_ref; - - # join all values into a single string - return join "///", @strings; -} - -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); - 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 - } - } -} - - -sub parse { - my $s = shift; - - # tokenize string - my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; - - my $tree = _recurse_parse($tokens); - return $tree; -} - -sub _recurse_parse { - my $tokens = shift; - - my $left; - while (1) { # left-associative parsing - - my $lookahead = $tokens->[0]; - return $left if !defined($lookahead) || $lookahead eq ')'; - - my $token = shift @$tokens; - - # nested expression in () - if ($token eq '(') { - my $right = _recurse_parse($tokens); - $token = shift @$tokens or croak "missing ')'"; - $token eq ')' or croak "unexpected token : $token"; - $left = $left ? [CONCAT => [$left, [PAREN => $right]]] - : [PAREN => $right]; - } - # AND/OR - elsif ($token eq 'AND' || $token eq 'OR') { - my $right = _recurse_parse($tokens); - $left = [$token => [$left, $right]]; - } - # leaf expression - else { - $left = $left ? [CONCAT => [$left, [EXPR => $token]]] - : [EXPR => $token]; - } - } -} - - - -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]}->(); -} - - -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 qw/is_same_sql_bind/; - - my ($sql, @bind) = SQL::Abstract->new->select(%args); - is_same_sql_bind($given_sql, \@given_bind, - $expected_sql, \@expected_bind, $test_msg); - -=head1 DESCRIPTION - -This module is only intended for authors of tests on -L and related modules; -it exports functions for comparing two SQL statements -and their bound values. - -The SQL comparison is performed on I, -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 : 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. - -=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 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. - -=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. - -=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). - -=head1 GLOBAL VARIABLES - -=head2 case_sensitive - -If true, SQL comparisons will be case-sensitive. Default is false; - -=head2 sql_differ - -When L returns false, the global variable -C<$sql_differ> contains the SQL portion -where a difference was encountered. - - -=head1 SEE ALSO - -L, L. - -=head1 AUTHOR - -Laurent Dami, Elaurent.dami AT etat geneve chE - -=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. +package SQL::Abstract::Test; # see doc at end of file + +use strict; +use warnings; +use Test::More; +use base 'Exporter'; +use Data::Dumper; +use Carp; + +our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind + $case_sensitive $sql_differ/; + +our $case_sensitive = 0; +our $sql_differ; # keeps track of differing portion between SQLs + +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_bind = eq_bind($bind_ref1, $bind_ref2); + + # call Test::More::ok + ok($same_sql && $same_bind, $msg); + + # add debugging info + if (!$same_sql) { + diag "SQL expressions differ\n" + ." got: $sql1\n" + ."expected: $sql2\n" + ."differing in :\n$sql_differ\n"; + ; + } + if (!$same_bind) { + diag "BIND values differ\n" + ." got: " . Dumper($bind_ref1) + ."expected: " . Dumper($bind_ref2) + ; + } +} + + +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 || []; + + # some bind values can be arrayrefs (see L), + # so stringify them. + my @strings = map {ref $_ eq 'ARRAY' ? join('=>', @$_) : ($_ || '')} + @$bind_ref; + + # join all values into a single string + return join "///", @strings; +} + +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); + 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 + } + } +} + + +sub parse { + my $s = shift; + + # tokenize string + my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; + + my $tree = _recurse_parse($tokens); + return $tree; +} + +sub _recurse_parse { + my $tokens = shift; + + my $left; + while (1) { # left-associative parsing + + my $lookahead = $tokens->[0]; + return $left if !defined($lookahead) || $lookahead eq ')'; + + my $token = shift @$tokens; + + # nested expression in () + if ($token eq '(') { + my $right = _recurse_parse($tokens); + $token = shift @$tokens or croak "missing ')'"; + $token eq ')' or croak "unexpected token : $token"; + $left = $left ? [CONCAT => [$left, [PAREN => $right]]] + : [PAREN => $right]; + } + # AND/OR + elsif ($token eq 'AND' || $token eq 'OR') { + my $right = _recurse_parse($tokens); + $left = [$token => [$left, $right]]; + } + # leaf expression + else { + $left = $left ? [CONCAT => [$left, [EXPR => $token]]] + : [EXPR => $token]; + } + } +} + + + +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]}->(); +} + + +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 qw/is_same_sql_bind/; + + my ($sql, @bind) = SQL::Abstract->new->select(%args); + is_same_sql_bind($given_sql, \@given_bind, + $expected_sql, \@expected_bind, $test_msg); + +=head1 DESCRIPTION + +This module is only intended for authors of tests on +L and related modules; +it exports functions for comparing two SQL statements +and their bound values. + +The SQL comparison is performed on I, +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 : 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. + +=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 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. + +=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. + +=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). + +=head1 GLOBAL VARIABLES + +=head2 case_sensitive + +If true, SQL comparisons will be case-sensitive. Default is false; + +=head2 sql_differ + +When L returns false, the global variable +C<$sql_differ> contains the SQL portion +where a difference was encountered. + + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Laurent Dami, Elaurent.dami AT etat geneve chE + +=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. diff --git a/t/02where.t b/t/02where.t index f71a411..331ffd0 100644 --- a/t/02where.t +++ b/t/02where.t @@ -4,9 +4,9 @@ use strict; use warnings; use Test::More; use Test::Exception; - use SQL::Abstract::Test qw/is_same_sql_bind/; -plan tests => 16; + +plan tests => 17; use SQL::Abstract; @@ -182,6 +182,12 @@ my @handle_tests = ( bind => [ 1 ], }, + { + where => { foo => SQLA::FourtyTwo->new(), }, + stmt => " WHERE ( foo = ? )", + bind => [ 'The Life, the Universe and Everything.' ], + }, + ); @@ -194,4 +200,28 @@ for my $case (@handle_tests) { dies_ok { my $sql = SQL::Abstract->new; $sql->where({ foo => { '>=' => [] }},); +}; + + + +#====================================================================== +package SQLA::FourtyTwo; # testing stringification of arguments +#====================================================================== + +use strict; +use warnings; + +use overload + '""' => \&to_str; + +sub new +{ + bless {}, shift; +} + +sub to_str +{ + return "The Life, the Universe and Everything."; } + +1;