[Bast-commits] r5235 - in
SQL-Abstract/1.x/branches/1.50_RC-extraparens: . lib/SQL
lib/SQL/Abstract t
norbi at dev.catalyst.perl.org
norbi at dev.catalyst.perl.org
Mon Dec 15 21:23:49 GMT 2008
Author: norbi
Date: 2008-12-15 21:23:49 +0000 (Mon, 15 Dec 2008)
New Revision: 5235
Modified:
SQL-Abstract/1.x/branches/1.50_RC-extraparens/
SQL-Abstract/1.x/branches/1.50_RC-extraparens/Makefile.PL
SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract.pm
SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract/Test.pm
SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/01generate.t
SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/02where.t
SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/10test.t
Log:
r5308 at vger: mendel | 2008-12-15 22:19:39 +0100
* Merged changes from trunk.
Property changes on: SQL-Abstract/1.x/branches/1.50_RC-extraparens
___________________________________________________________________
Name: svn:ignore
- Makefile
blib
pm_to_blib
+ Makefile
Makefile.old
blib
pm_to_blib
Name: svk:merge
- 4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC:5202
4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC-extraparens:5303
+ 4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC:5305
4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/SQL-Abstract/1.x/branches/1.50_RC-extraparens:5308
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/1.50_RC:5107
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/Makefile.PL
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/Makefile.PL 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/Makefile.PL 2008-12-15 21:23:49 UTC (rev 5235)
@@ -6,7 +6,13 @@
NAME => 'SQL::Abstract',
VERSION_FROM => 'lib/SQL/Abstract.pm', # finds $VERSION
PREREQ_PM => {
- "List::Util" => 0
+ "List::Util" => 0,
+ "Scalar::Util" => 0,
+ "Test::Builder" => 0,
+ "Test::More" => 0,
+ "Test::Exception" => 0,
+ "Test::Deep" => 0,
+ "Data::Dumper" => 0,
}, # e.g., Module::Name => 1.1
ABSTRACT_FROM => 'lib/SQL/Abstract.pm', # retrieve abstract from module
AUTHOR => 'Nathan Wiger (nate at wiger.org)',
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract/Test.pm
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract/Test.pm 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract/Test.pm 2008-12-15 21:23:49 UTC (rev 5235)
@@ -3,8 +3,11 @@
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
$case_sensitive $sql_differ/;
@@ -91,31 +94,10 @@
}
}
-
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<SQL::Abstract/bindtype>),
- # so stringify them.
- # furthermore, if L<SQL::Abstract/array_datatypes> is set to true, elements
- # of those arrayrefs can be arrayrefs, too.
- my @strings = map {
- ref $_ eq 'ARRAY'
- ? join('=>', map {
- ref $_ eq 'ARRAY'
- ? ('[' . join('=>', @$_) . ']')
- : (defined $_ ? $_ : '')
- } @$_)
- : (defined $_ ? $_ : '')
- } @$bind_ref;
-
- # join all values into a single string
- return join "///", @strings;
+ return eq_deeply($bind_ref1, $bind_ref2);
}
sub eq_sql {
@@ -276,9 +258,9 @@
$expected_sql, \@expected_bind, $test_msg);
Compares given and expected pairs of C<($sql, \@bind)>, and calls
-L<Test::More/ok> on the result, with C<$test_msg> as message. If the
+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::More|Test::More>, this is the only function that needs to be
+L<Test::Build>, this is the only function that needs to be
imported.
=head2 eq_sql
@@ -312,7 +294,7 @@
=head1 SEE ALSO
-L<SQL::Abstract>, L<Test::More>.
+L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
=head1 AUTHORS
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract.pm
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract.pm 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/lib/SQL/Abstract.pm 2008-12-15 21:23:49 UTC (rev 5235)
@@ -536,6 +536,14 @@
$$val;
},
+ ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]}
+ my ($sub_sql, @sub_bind) = @$$val;
+ $sql = join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($op),
+ $sub_sql;
+ @bind = @sub_bind;
+ },
+
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is = ($op =~ $self->{equality_op}) ? 'is' :
($op =~ $self->{inequality_op}) ? 'is not' :
@@ -1607,7 +1615,20 @@
$stmt = "WHERE user = ? AND priority = ? OR priority != ?";
@bind = ('nwiger', '2', '1');
+If you want to include literal SQL (with or without bind values), just use a
+scalar reference or array reference as the value:
+ my %where = (
+ date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
+ date_expires => { '<' => \"now()" }
+ );
+
+Which would generate:
+
+ $stmt = "WHERE date_entered > "to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
+ @bind = ('11/26/2008');
+
+
=head2 Logic and nesting operators
In the example above,
@@ -2077,6 +2098,10 @@
=item *
+support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
+
+=item *
+
added -nest1, -nest2 or -nest_1, -nest_2, ...
=item *
@@ -2139,6 +2164,7 @@
Dan Kubb (support for "quote_char" and "name_sep")
Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
Laurent Dami (internal refactoring, multiple -nest, extensible list of special operators, literal SQL)
+ Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
Thanks!
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/01generate.t
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/01generate.t 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/01generate.t 2008-12-15 21:23:49 UTC (rev 5235)
@@ -352,6 +352,14 @@
stmt_q => 'SELECT * FROM `test` WHERE ( `a` > 1 + 1 AND `b` = ? )',
bind => [8],
},
+ #38
+ {
+ func => 'select',
+ args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }],
+ stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )',
+ stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )',
+ bind => ['02/02/02', 8],
+ },
);
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/02where.t
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/02where.t 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/02where.t 2008-12-15 21:23:49 UTC (rev 5235)
@@ -11,7 +11,7 @@
# Make sure to test the examples, since having them break is somewhat
# embarrassing. :-(
-my $not_stringifiable = SQLA::NotStringifiable->new();
+my $not_stringifiable = bless {}, 'SQLA::NotStringifiable';
my @handle_tests = (
{
@@ -183,12 +183,6 @@
},
{
- where => { foo => SQLA::FourtyTwo->new(), },
- stmt => " WHERE ( foo = ? )",
- bind => [ 'The Life, the Universe and Everything.' ],
- },
-
- {
where => { foo => $not_stringifiable, },
stmt => " WHERE ( foo = ? )",
bind => [ $not_stringifiable ],
@@ -209,42 +203,3 @@
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;
-
-
-#======================================================================
-package SQLA::NotStringifiable; # testing stringification of arguments
-#======================================================================
-
-use strict;
-use warnings;
-
-sub new
-{
- bless {}, shift;
-}
-
-1;
Modified: SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/10test.t
===================================================================
--- SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/10test.t 2008-12-11 16:51:29 UTC (rev 5234)
+++ SQL-Abstract/1.x/branches/1.50_RC-extraparens/t/10test.t 2008-12-15 21:23:49 UTC (rev 5235)
@@ -452,12 +452,210 @@
},
);
+my @bind_tests = (
+ # scalar - equal
+ {
+ equal => 1,
+ bindvals => [
+ undef,
+ undef,
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 'foo',
+ 'foo',
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 42,
+ 42,
+ '42',
+ ]
+ },
-plan tests => 1 + sum
- map { $_ * ($_ - 1) / 2 }
- map { scalar @{$_->{statements}} }
- @sql_tests;
+ # scalarref - equal
+ {
+ equal => 1,
+ bindvals => [
+ \'foo',
+ \'foo',
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ \42,
+ \42,
+ \'42',
+ ]
+ },
+ # arrayref - equal
+ {
+ equal => 1,
+ bindvals => [
+ [],
+ []
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ [42],
+ [42],
+ ['42'],
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ [1, 42],
+ [1, 42],
+ ['1', 42],
+ [1, '42'],
+ ['1', '42'],
+ ]
+ },
+
+ # hashref - equal
+ {
+ equal => 1,
+ bindvals => [
+ { foo => 42 },
+ { foo => 42 },
+ { foo => '42' },
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ { foo => 42, bar => 1 },
+ { foo => 42, bar => 1 },
+ { foo => '42', bar => 1 },
+ ]
+ },
+
+ # blessed object - equal
+ {
+ equal => 1,
+ bindvals => [
+ bless(\(local $_ = 42), 'Life::Universe::Everything'),
+ bless(\(local $_ = 42), 'Life::Universe::Everything'),
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ bless([42], 'Life::Universe::Everything'),
+ bless([42], 'Life::Universe::Everything'),
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ bless({ answer => 42 }, 'Life::Universe::Everything'),
+ bless({ answer => 42 }, 'Life::Universe::Everything'),
+ ]
+ },
+
+ # complex data structure - equal
+ {
+ equal => 1,
+ bindvals => [
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ ]
+ },
+
+
+ # scalar - different
+ {
+ equal => 0,
+ bindvals => [
+ undef,
+ 'foo',
+ 42,
+ ]
+ },
+
+ # scalarref - different
+ {
+ equal => 0,
+ bindvals => [
+ \undef,
+ \'foo',
+ \42,
+ ]
+ },
+
+ # arrayref - different
+ {
+ equal => 0,
+ bindvals => [
+ [undef],
+ ['foo'],
+ [42],
+ ]
+ },
+
+ # hashref - different
+ {
+ equal => 0,
+ bindvals => [
+ { foo => undef },
+ { foo => 'bar' },
+ { foo => 42 },
+ ]
+ },
+
+ # different types
+ {
+ equal => 0,
+ bindvals => [
+ 'foo',
+ \'foo',
+ ['foo'],
+ { foo => 'bar' },
+ ]
+ },
+
+ # complex data structure - different
+ {
+ equal => 0,
+ bindvals => [
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [43, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'baz', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { bar => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quuux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [0, 1, 2, \3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, 3, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \4, { quux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quuux => [4, 5] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5, 6] } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => 4 } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5], quuux => 1 } ] }, 8 ],
+ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8, 9 ],
+ ]
+ },
+);
+
+plan tests => 1 +
+ sum(
+ map { $_ * ($_ - 1) / 2 }
+ map { scalar @{$_->{statements}} }
+ @sql_tests
+ ) +
+ sum(
+ map { $_ * ($_ - 1) / 2 }
+ map { scalar @{$_->{bindvals}} }
+ @bind_tests
+ );
+
use_ok('SQL::Abstract::Test', import => [qw(eq_sql eq_bind is_same_sql_bind)]);
for my $test (@sql_tests) {
@@ -479,3 +677,23 @@
}
}
}
+
+for my $test (@bind_tests) {
+ my $bindvals = $test->{bindvals};
+ while (@$bindvals) {
+ my $bind1 = shift @$bindvals;
+ foreach my $bind2 (@$bindvals) {
+ my $equal = eq_bind($bind1, $bind2);
+ if ($test->{equal}) {
+ ok($equal, "equal bind values considered equal");
+ } else {
+ ok(!$equal, "different bind values considered not equal");
+ }
+
+ if ($equal ^ $test->{equal}) {
+ diag("bind1: " . Dumper($bind1));
+ diag("bind2: " . Dumper($bind2));
+ }
+ }
+ }
+}
More information about the Bast-commits
mailing list