[Bast-commits] r5773 - in SQL-Abstract/1.x/trunk: . lib/SQL
lib/SQL/Abstract t
robkinyon at dev.catalyst.perl.org
robkinyon at dev.catalyst.perl.org
Thu Mar 19 18:58:41 GMT 2009
Author: robkinyon
Date: 2009-03-19 18:58:41 +0000 (Thu, 19 Mar 2009)
New Revision: 5773
Added:
SQL-Abstract/1.x/trunk/lib/SQL/Abstract/
SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Test.pm
SQL-Abstract/1.x/trunk/t/07subqueries.t
SQL-Abstract/1.x/trunk/t/08special_ops.t
SQL-Abstract/1.x/trunk/t/09refkind.t
SQL-Abstract/1.x/trunk/t/10test.t
Removed:
SQL-Abstract/1.x/trunk/t/04from.t
SQL-Abstract/1.x/trunk/t/05quotes.t
Modified:
SQL-Abstract/1.x/trunk/Changes
SQL-Abstract/1.x/trunk/Makefile.PL
SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm
SQL-Abstract/1.x/trunk/t/00new.t
SQL-Abstract/1.x/trunk/t/01generate.t
SQL-Abstract/1.x/trunk/t/02where.t
SQL-Abstract/1.x/trunk/t/03values.t
SQL-Abstract/1.x/trunk/t/06order_by.t
Log:
cp -r from branches/1.50_RC where svk push won't work
Modified: SQL-Abstract/1.x/trunk/Changes
===================================================================
--- SQL-Abstract/1.x/trunk/Changes 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/Changes 2009-03-19 18:58:41 UTC (rev 5773)
@@ -1,10 +1,58 @@
Revision history for SQL::Abstract
+----------------------------
+revision 1.50 2009-03-10 12:30 (UTC)
+ - fixed the problem with values() not behaving the same as the rest of the code (RT#43483)
+ - fixed interjecting arrayrefref into a where clause
+ - added value-only insert test with a literal SQL snippet
+ - cleanup and enhancement of t/03values.t
+ - better handling of borked SQL in tests
+ - deal properly with parentheses in is_same_sql_bind()
+ - fixed test subs (is_same_*) in SQL::Abstract::Test to return the correct test value
+ - do not version MANIFEST
+
+ Version 1.50 was a major internal refactoring of SQL::Abstract.
+ Great care has been taken to preserve the published behavior
+ documented in previous versions in the 1.* family; however,
+ some features that were previously undocumented, or behaved.
+ differently from the documentation, had to be changed in order
+ to clarify the semantics. Hence, client code that was relying
+ on some dark areas of SQL::Abstract v1.* might behave differently
+ in v1.50.
+
+----------------------------
+revision 1.49_04 2009-03-03
+ - add support for a [\%column_meta => value] bind value format
+
+----------------------------
+revision 1.49_03 2009-02-17
+ - clarify syntax of \['...', @bind] when used with a bindtype
+ of 'columns'
+
+----------------------------
+revision 1.49_02 2009-02-16
+ - added an AST-aware SQL::Abstract::Test library for sql syntax tests
+ - vastly expanded test coverage
+ - support for the { operator => \'...'|\['...', @bind] } syntax
+ allowing to embed arbitrary operators on the LHS
+ - fixed multiple regressions wrt DBIx::Class
+
+----------------------------
+revision 1.49_01 2009-02-11
+ - support for literal SQL through the [$sql, bind] syntax.
+ - added -nest1, -nest2 or -nest_1, -nest_2, ...
+ - optional support for array datatypes
+ - defensive programming : check arguments to functions/methods
+ - fixed bug with global logic of -and/-or (no side-effects any more)
+ - changed logic for distributing an op over arrayrefs
+ - fixed semantics of _bindtype on array args
+ - dropped the _anoncopy of the %where tree. No longer necessary.
+ - dropped the _modlogic function
- Make col => [] and col => {$op => [] } DTRT or die instead of generating
- broken SQL. Added tests for this.
- - Added { -desc => 'column' } order by support (Ash)
- - Tiny "$_"-related fix for { -desc => 'columns'} order by support
- - tests + docs (groditi)
+ broken SQL. Added tests for this.
+ - Added { -desc => 'column' } order by support
+ - Tiny "$_"-related fix for { -desc => 'columns'} order by support
+ tests + docs
----------------------------
revision 1.20
Modified: SQL-Abstract/1.x/trunk/Makefile.PL
===================================================================
--- SQL-Abstract/1.x/trunk/Makefile.PL 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/Makefile.PL 2009-03-19 18:58:41 UTC (rev 5773)
@@ -3,9 +3,18 @@
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
- NAME => 'SQL::Abstract',
- VERSION_FROM => 'lib/SQL/Abstract.pm', # finds $VERSION
- PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ NAME => 'SQL::Abstract',
+ VERSION_FROM => 'lib/SQL/Abstract.pm', # finds $VERSION
+ PREREQ_PM => {
+ "List::Util" => 0,
+ "Scalar::Util" => 0,
+ "Test::Builder" => 0,
+ "Test::More" => 0,
+ "Test::Exception" => 0,
+ "Test::Warn" => 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)',
+ AUTHOR => 'Matt Trout <mst at shadowcat.co.uk>, but see the POD',
);
Added: SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Test.pm
===================================================================
--- SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Test.pm (rev 0)
+++ SQL-Abstract/1.x/trunk/lib/SQL/Abstract/Test.pm 2009-03-19 18:58:41 UTC (rev 5773)
@@ -0,0 +1,419 @@
+package SQL::Abstract::Test; # see doc at end of file
+
+use strict;
+use warnings;
+use base qw/Test::Builder::Module Exporter/;
+use Data::Dumper;
+use Carp;
+use Test::Builder;
+use Test::Deep qw(eq_deeply);
+
+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 $same_sql = eq_sql($sql1, $sql2);
+ my $same_bind = eq_bind($bind_ref1, $bind_ref2);
+
+ # call Test::Builder::ok
+ 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) {
+ _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) {
+ _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) = @_;
+
+ return eq_deeply($bind_ref1, $bind_ref2);
+}
+
+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 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
+ elsif ($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, 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, PARSE_TOP_LEVEL);
+ return $tree;
+}
+
+sub _recurse_parse {
+ my ($tokens, $state) = @_;
+
+ my $left;
+ while (1) { # left-associative parsing
+
+ 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
+ );
+
+ my $token = shift @$tokens;
+
+ # 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];
+ }
+ # AND/OR
+ elsif ($token eq 'AND' || $token eq 'OR') {
+ 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]]]
+ : [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 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> : 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<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>,
+this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
+L</is_same_bind>) 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<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>, this is the one of
+the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
+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<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>, this is the one of the three
+functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) 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</is_same_sql_bind>, but it just returns a boolean value and does not print
+diagnostics or talk to L<Test::Builder>.
+
+=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 $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>
+
+Norbert Buchmuller <norbi at nix.hu>
+
+=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.
Modified: SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm
===================================================================
--- SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm 2009-03-19 18:58:41 UTC (rev 5773)
@@ -1,5 +1,1122 @@
-package SQL::Abstract;
+package SQL::Abstract; # see doc at end of file
+# LDNOTE : this code is heavy refactoring from original SQLA.
+# Several design decisions will need discussion during
+# the test / diffusion / acceptance phase; those are marked with flag
+# 'LDNOTE' (note by laurent.dami AT free.fr)
+
+use Carp;
+use strict;
+use warnings;
+use List::Util qw/first/;
+use Scalar::Util qw/blessed/;
+
+#======================================================================
+# GLOBALS
+#======================================================================
+
+our $VERSION = '1.50';
+
+# This would confuse some packagers
+#$VERSION = eval $VERSION; # numify for warning-free dev releases
+
+our $AUTOLOAD;
+
+# special operators (-in, -between). May be extended/overridden by user.
+# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
+my @BUILTIN_SPECIAL_OPS = (
+ {regex => qr/^(not )?between$/i, handler => \&_where_field_BETWEEN},
+ {regex => qr/^(not )?in$/i, handler => \&_where_field_IN},
+);
+
+#======================================================================
+# DEBUGGING AND ERROR REPORTING
+#======================================================================
+
+sub _debug {
+ return unless $_[0]->{debug}; shift; # a little faster
+ my $func = (caller(1))[3];
+ warn "[$func] ", @_, "\n";
+}
+
+sub belch (@) {
+ my($func) = (caller(1))[3];
+ carp "[$func] Warning: ", @_;
+}
+
+sub puke (@) {
+ my($func) = (caller(1))[3];
+ croak "[$func] Fatal: ", @_;
+}
+
+
+#======================================================================
+# NEW
+#======================================================================
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
+
+ # choose our case by keeping an option around
+ delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
+
+ # default logic for interpreting arrayrefs
+ $opt{logic} = uc $opt{logic} || 'OR';
+
+ # how to return bind vars
+ # LDNOTE: changed nwiger code : why this 'delete' ??
+ # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
+ $opt{bindtype} ||= 'normal';
+
+ # default comparison is "=", but can be overridden
+ $opt{cmp} ||= '=';
+
+ # try to recognize which are the 'equality' and 'unequality' ops
+ # (temporary quickfix, should go through a more seasoned API)
+ $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
+ $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
+
+ # SQL booleans
+ $opt{sqltrue} ||= '1=1';
+ $opt{sqlfalse} ||= '0=1';
+
+ # special operators
+ $opt{special_ops} ||= [];
+ push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
+
+ return bless \%opt, $class;
+}
+
+
+
+#======================================================================
+# INSERT methods
+#======================================================================
+
+sub insert {
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+
+ my $method = $self->_METHOD_FOR_refkind("_insert", $data);
+ my ($sql, @bind) = $self->$method($data);
+ $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+sub _insert_HASHREF { # explicit list of fields and then values
+ my ($self, $data) = @_;
+
+ my @fields = sort keys %$data;
+
+ my ($sql, @bind) = $self->_insert_values($data);
+
+ # assemble SQL
+ $_ = $self->_quote($_) foreach @fields;
+ $sql = "( ".join(", ", @fields).") ".$sql;
+
+ return ($sql, @bind);
+}
+
+sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
+ my ($self, $data) = @_;
+
+ # no names (arrayref) so can't generate bindtype
+ $self->{bindtype} ne 'columns'
+ or belch "can't do 'columns' bindtype when called with arrayref";
+
+ # fold the list of values into a hash of column name - value pairs
+ # (where the column names are artificially generated, and their
+ # lexicographical ordering keep the ordering of the original list)
+ my $i = "a"; # incremented values will be in lexicographical order
+ my $data_in_hash = { map { ($i++ => $_) } @$data };
+
+ return $self->_insert_values($data_in_hash);
+}
+
+sub _insert_ARRAYREFREF { # literal SQL with bind
+ my ($self, $data) = @_;
+
+ my ($sql, @bind) = @${$data};
+ $self->_assert_bindval_matches_bindtype(@bind);
+
+ return ($sql, @bind);
+}
+
+
+sub _insert_SCALARREF { # literal SQL without bind
+ my ($self, $data) = @_;
+
+ return ($$data);
+}
+
+sub _insert_values {
+ my ($self, $data) = @_;
+
+ my (@values, @all_bind);
+ foreach my $column (sort keys %$data) {
+ my $v = $data->{$column};
+
+ $self->_SWITCH_refkind($v, {
+
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}) { # if array datatype are activated
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ }
+ else { # else literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ }
+ },
+
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ },
+
+ # THINK : anything useful to do with a HASHREF ?
+ HASHREF => sub { # (nothing, but old SQLA passed it through)
+ #TODO in SQLA >= 2.0 it will die instead
+ belch "HASH ref as bind value in insert is not supported";
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
+
+ SCALARREF => sub { # literal SQL without bind
+ push @values, $$v;
+ },
+
+ SCALAR_or_UNDEF => sub {
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
+
+ });
+
+ }
+
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
+}
+
+
+
+#======================================================================
+# UPDATE methods
+#======================================================================
+
+
+sub update {
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $where = shift;
+
+ # first build the 'SET' part of the sql statement
+ my (@set, @all_bind);
+ puke "Unsupported data type specified to \$sql->update"
+ unless ref $data eq 'HASH';
+
+ for my $k (sort keys %$data) {
+ my $v = $data->{$k};
+ my $r = ref $v;
+ my $label = $self->_quote($k);
+
+ $self->_SWITCH_refkind($v, {
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}) { # array datatype
+ push @set, "$label = ?";
+ push @all_bind, $self->_bindtype($k, $v);
+ }
+ else { # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ }
+ },
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ },
+ SCALARREF => sub { # literal SQL without bind
+ push @set, "$label = $$v";
+ },
+ SCALAR_or_UNDEF => sub {
+ push @set, "$label = ?";
+ push @all_bind, $self->_bindtype($k, $v);
+ },
+ });
+ }
+
+ # generate sql
+ my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
+ . join ', ', @set;
+
+ if ($where) {
+ my($where_sql, @where_bind) = $self->where($where);
+ $sql .= $where_sql;
+ push @all_bind, @where_bind;
+ }
+
+ return wantarray ? ($sql, @all_bind) : $sql;
+}
+
+
+
+
+#======================================================================
+# SELECT
+#======================================================================
+
+
+sub select {
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $fields = shift || '*';
+ my $where = shift;
+ my $order = shift;
+
+ my($where_sql, @bind) = $self->where($where, $order);
+
+ my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
+ : $fields;
+ my $sql = join(' ', $self->_sqlcase('select'), $f,
+ $self->_sqlcase('from'), $table)
+ . $where_sql;
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+#======================================================================
+# DELETE
+#======================================================================
+
+
+sub delete {
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $where = shift;
+
+
+ my($where_sql, @bind) = $self->where($where);
+ my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+
+#======================================================================
+# WHERE: entry point
+#======================================================================
+
+
+
+# Finally, a separate routine just to handle WHERE clauses
+sub where {
+ my ($self, $where, $order) = @_;
+
+ # where ?
+ my ($sql, @bind) = $self->_recurse_where($where);
+ $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
+
+ # order by?
+ if ($order) {
+ $sql .= $self->_order_by($order);
+ }
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+
+sub _recurse_where {
+ my ($self, $where, $logic) = @_;
+
+ # dispatch on appropriate method according to refkind of $where
+ my $method = $self->_METHOD_FOR_refkind("_where", $where);
+
+
+ my ($sql, @bind) = $self->$method($where, $logic);
+
+ # DBIx::Class directly calls _recurse_where in scalar context, so
+ # we must implement it, even if not in the official API
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+
+
+#======================================================================
+# WHERE: top-level ARRAYREF
+#======================================================================
+
+
+sub _where_ARRAYREF {
+ my ($self, $where, $logic) = @_;
+
+ $logic = uc($logic || $self->{logic});
+ $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
+
+ my @clauses = @$where;
+
+ # if the array starts with [-and|or => ...], recurse with that logic
+ my $first = $clauses[0] || '';
+ if ($first =~ /^-(and|or)/i) {
+ $logic = $1;
+ shift @clauses;
+ return $self->_where_ARRAYREF(\@clauses, $logic);
+ }
+
+ #otherwise..
+ my (@sql_clauses, @all_bind);
+
+ # need to use while() so can shift() for pairs
+ while (my $el = shift @clauses) {
+
+ # switch according to kind of $el and get corresponding ($sql, @bind)
+ my ($sql, @bind) = $self->_SWITCH_refkind($el, {
+
+ # skip empty elements, otherwise get invalid trailing AND stuff
+ ARRAYREF => sub {$self->_recurse_where($el) if @$el},
+
+ ARRAYREFREF => sub { @{${$el}} if @{${$el}}},
+
+ HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
+ # LDNOTE : previous SQLA code for hashrefs was creating a dirty
+ # side-effect: the first hashref within an array would change
+ # the global logic to 'AND'. So [ {cond1, cond2}, [cond3, cond4] ]
+ # was interpreted as "(cond1 AND cond2) OR (cond3 AND cond4)",
+ # whereas it should be "(cond1 AND cond2) OR (cond3 OR cond4)".
+
+ SCALARREF => sub { ($$el); },
+
+ SCALAR => sub {# top-level arrayref with scalars, recurse in pairs
+ $self->_recurse_where({$el => shift(@clauses)})},
+
+ UNDEF => sub {puke "not supported : UNDEF in arrayref" },
+ });
+
+ if ($sql) {
+ push @sql_clauses, $sql;
+ push @all_bind, @bind;
+ }
+ }
+
+ return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
+}
+
+#======================================================================
+# WHERE: top-level ARRAYREFREF
+#======================================================================
+
+sub _where_ARRAYREFREF {
+ my ($self, $where) = @_;
+ my ($sql, @bind) = @{${$where}};
+
+ return ($sql, @bind);
+}
+
+#======================================================================
+# WHERE: top-level HASHREF
+#======================================================================
+
+sub _where_HASHREF {
+ my ($self, $where) = @_;
+ my (@sql_clauses, @all_bind);
+
+ # LDNOTE : don't really know why we need to sort keys
+ for my $k (sort keys %$where) {
+ my $v = $where->{$k};
+
+ # ($k => $v) is either a special op or a regular hashpair
+ my ($sql, @bind) = ($k =~ /^-(.+)/) ? $self->_where_op_in_hash($1, $v)
+ : do {
+ my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
+ $self->$method($k, $v);
+ };
+
+ push @sql_clauses, $sql;
+ push @all_bind, @bind;
+ }
+
+ return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
+}
+
+
+sub _where_op_in_hash {
+ my ($self, $op, $v) = @_;
+
+ $op =~ /^(AND|OR|NEST)[_\d]*/i
+ or puke "unknown operator: -$op";
+ $op = uc($1); # uppercase, remove trailing digits
+ $self->_debug("OP(-$op) within hashref, recursing...");
+
+ $self->_SWITCH_refkind($v, {
+
+ ARRAYREF => sub {
+ # LDNOTE : should deprecate {-or => [...]} and {-and => [...]}
+ # because they are misleading; the only proper way would be
+ # -nest => [-or => ...], -nest => [-and ...]
+ return $self->_where_ARRAYREF($v, $op eq 'NEST' ? '' : $op);
+ },
+
+ HASHREF => sub {
+ if ($op eq 'OR') {
+ belch "-or => {...} should be -nest => [...]";
+ return $self->_where_ARRAYREF([%$v], 'OR');
+ }
+ else { # NEST | AND
+ return $self->_where_HASHREF($v);
+ }
+ },
+
+ SCALARREF => sub { # literal SQL
+ $op eq 'NEST'
+ or puke "-$op => \\\$scalar not supported, use -nest => ...";
+ return ($$v);
+ },
+
+ ARRAYREFREF => sub { # literal SQL
+ $op eq 'NEST'
+ or puke "-$op => \\[..] not supported, use -nest => ...";
+ return @{${$v}};
+ },
+
+ SCALAR => sub { # permissively interpreted as SQL
+ $op eq 'NEST'
+ or puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
+ belch "literal SQL should be -nest => \\'scalar' "
+ . "instead of -nest => 'scalar' ";
+ return ($v);
+ },
+
+ UNDEF => sub {
+ puke "-$op => undef not supported";
+ },
+ });
+}
+
+
+sub _where_hashpair_ARRAYREF {
+ my ($self, $k, $v) = @_;
+
+ if( @$v ) {
+ my @v = @$v; # need copy because of shift below
+ $self->_debug("ARRAY($k) means distribute over elements");
+
+ # put apart first element if it is an operator (-and, -or)
+ my $op = $v[0] =~ /^-/ ? shift @v : undef;
+ $self->_debug("OP($op) reinjected into the distributed array") if $op;
+
+ my @distributed = map { {$k => $_} } @v;
+ unshift @distributed, $op if $op;
+
+ return $self->_recurse_where(\@distributed);
+ }
+ else {
+ # LDNOTE : not sure of this one. What does "distribute over nothing" mean?
+ $self->_debug("empty ARRAY($k) means 0=1");
+ return ($self->{sqlfalse});
+ }
+}
+
+sub _where_hashpair_HASHREF {
+ my ($self, $k, $v) = @_;
+
+ my (@all_sql, @all_bind);
+
+ for my $op (sort keys %$v) {
+ my $val = $v->{$op};
+
+ # put the operator in canonical form
+ $op =~ s/^-//; # remove initial dash
+ $op =~ tr/_/ /; # underscores become spaces
+ $op =~ s/^\s+//; # no initial space
+ $op =~ s/\s+$//; # no final space
+ $op =~ s/\s+/ /; # multiple spaces become one
+
+ my ($sql, @bind);
+
+ # CASE: special operators like -in or -between
+ my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}};
+ if ($special_op) {
+ ($sql, @bind) = $special_op->{handler}->($self, $k, $op, $val);
+ }
+ else {
+ $self->_SWITCH_refkind($val, {
+
+ ARRAYREF => sub { # CASE: col => {op => \@vals}
+ ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
+ },
+
+ SCALARREF => sub { # CASE: col => {op => \$scalar} (literal SQL without bind)
+ $sql = join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($op),
+ $$val;
+ },
+
+ ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
+ my ($sub_sql, @sub_bind) = @$$val;
+ $self->_assert_bindval_matches_bindtype(@sub_bind);
+ $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' :
+ puke "unexpected operator '$op' with undef operand";
+ $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
+ },
+
+ FALLBACK => sub { # CASE: col => {op => $scalar}
+ $sql = join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($op),
+ $self->_convert('?');
+ @bind = $self->_bindtype($k, $val);
+ },
+ });
+ }
+
+ push @all_sql, $sql;
+ push @all_bind, @bind;
+ }
+
+ return $self->_join_sql_clauses('and', \@all_sql, \@all_bind);
+}
+
+
+
+sub _where_field_op_ARRAYREF {
+ my ($self, $k, $op, $vals) = @_;
+
+ if(@$vals) {
+ $self->_debug("ARRAY($vals) means multiple elements: [ @$vals ]");
+
+
+
+ # LDNOTE : change the distribution logic when
+ # $op =~ $self->{inequality_op}, because of Morgan laws :
+ # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate
+ # WHERE field != 22 OR field != 33 : the user probably means
+ # WHERE field != 22 AND field != 33.
+ my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR';
+
+ # distribute $op over each member of @$vals
+ return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic);
+
+ }
+ else {
+ # try to DWIM on equality operators
+ # LDNOTE : not 100% sure this is the correct thing to do ...
+ return ($self->{sqlfalse}) if $op =~ $self->{equality_op};
+ return ($self->{sqltrue}) if $op =~ $self->{inequality_op};
+
+ # otherwise
+ puke "operator '$op' applied on an empty array (field '$k')";
+ }
+}
+
+
+sub _where_hashpair_SCALARREF {
+ my ($self, $k, $v) = @_;
+ $self->_debug("SCALAR($k) means literal SQL: $$v");
+ my $sql = $self->_quote($k) . " " . $$v;
+ return ($sql);
+}
+
+# literal SQL with bind
+sub _where_hashpair_ARRAYREFREF {
+ my ($self, $k, $v) = @_;
+ $self->_debug("REF($k) means literal SQL: @${$v}");
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ $sql = $self->_quote($k) . " " . $sql;
+ return ($sql, @bind );
+}
+
+# literal SQL without bind
+sub _where_hashpair_SCALAR {
+ my ($self, $k, $v) = @_;
+ $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
+ my $sql = join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($self->{cmp}),
+ $self->_convert('?');
+ my @bind = $self->_bindtype($k, $v);
+ return ( $sql, @bind);
+}
+
+
+sub _where_hashpair_UNDEF {
+ my ($self, $k, $v) = @_;
+ $self->_debug("UNDEF($k) means IS NULL");
+ my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
+ return ($sql);
+}
+
+#======================================================================
+# WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
+#======================================================================
+
+
+sub _where_SCALARREF {
+ my ($self, $where) = @_;
+
+ # literal sql
+ $self->_debug("SCALAR(*top) means literal SQL: $$where");
+ return ($$where);
+}
+
+
+sub _where_SCALAR {
+ my ($self, $where) = @_;
+
+ # literal sql
+ $self->_debug("NOREF(*top) means literal SQL: $where");
+ return ($where);
+}
+
+
+sub _where_UNDEF {
+ my ($self) = @_;
+ return ();
+}
+
+
+#======================================================================
+# WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
+#======================================================================
+
+
+sub _where_field_BETWEEN {
+ my ($self, $k, $op, $vals) = @_;
+
+ ref $vals eq 'ARRAY' && @$vals == 2
+ or puke "special op 'between' requires an arrayref of two values";
+
+ my ($label) = $self->_convert($self->_quote($k));
+ my ($placeholder) = $self->_convert('?');
+ my $and = $self->_sqlcase('and');
+ $op = $self->_sqlcase($op);
+
+ my $sql = "( $label $op $placeholder $and $placeholder )";
+ my @bind = $self->_bindtype($k, @$vals);
+ return ($sql, @bind)
+}
+
+
+sub _where_field_IN {
+ my ($self, $k, $op, $vals) = @_;
+
+ # backwards compatibility : if scalar, force into an arrayref
+ $vals = [$vals] if defined $vals && ! ref $vals;
+
+ my ($label) = $self->_convert($self->_quote($k));
+ my ($placeholder) = $self->_convert('?');
+ $op = $self->_sqlcase($op);
+
+ my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
+ ARRAYREF => sub { # list of choices
+ if (@$vals) { # nonempty list
+ my $placeholders = join ", ", (($placeholder) x @$vals);
+ my $sql = "$label $op ( $placeholders )";
+ my @bind = $self->_bindtype($k, @$vals);
+
+ return ($sql, @bind);
+ }
+ else { # empty list : some databases won't understand "IN ()", so DWIM
+ my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
+ return ($sql);
+ }
+ },
+
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @$$vals;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ return ("$label $op ( $sql )", @bind);
+ },
+
+ FALLBACK => sub {
+ puke "special op 'in' requires an arrayref (or arrayref-ref)";
+ },
+ });
+
+ return ($sql, @bind);
+}
+
+
+
+
+
+
+#======================================================================
+# ORDER BY
+#======================================================================
+
+sub _order_by {
+ my ($self, $arg) = @_;
+
+ # construct list of ordering instructions
+ my @order = $self->_SWITCH_refkind($arg, {
+
+ 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;
+ },
+
+ SCALAR => sub {$self->_quote($arg)},
+ UNDEF => sub {},
+ SCALARREF => sub {$$arg}, # literal SQL, no quoting
+ HASHREF => sub {$self->_order_by_hash($arg)},
+
+ });
+
+ # build SQL
+ my $order = join ', ', @order;
+ return $order ? $self->_sqlcase(' order by')." $order" : '';
+}
+
+
+sub _order_by_hash {
+ my ($self, $hash) = @_;
+
+ # get first pair in hash
+ my ($key, $val) = each %$hash;
+
+ # check if one pair was found and no other pair in hash
+ $key && !(each %$hash)
+ or puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
+
+ my ($order) = ($key =~ /^-(desc|asc)/i)
+ or puke "invalid key in _order_by hash : $key";
+
+ return $self->_quote($val) ." ". $self->_sqlcase($order);
+}
+
+
+
+#======================================================================
+# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
+#======================================================================
+
+sub _table {
+ my $self = shift;
+ my $from = shift;
+ $self->_SWITCH_refkind($from, {
+ ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
+ SCALAR => sub {$self->_quote($from)},
+ SCALARREF => sub {$$from},
+ ARRAYREFREF => sub {join ', ', @$from;},
+ });
+}
+
+
+#======================================================================
+# UTILITY FUNCTIONS
+#======================================================================
+
+sub _quote {
+ my $self = shift;
+ my $label = shift;
+
+ $label or puke "can't quote an empty label";
+
+ # left and right quote characters
+ my ($ql, $qr, @other) = $self->_SWITCH_refkind($self->{quote_char}, {
+ SCALAR => sub {($self->{quote_char}, $self->{quote_char})},
+ ARRAYREF => sub {@{$self->{quote_char}}},
+ UNDEF => sub {()},
+ });
+ not @other
+ or puke "quote_char must be an arrayref of 2 values";
+
+ # no quoting if no quoting chars
+ $ql or return $label;
+
+ # no quoting for literal SQL
+ return $$label if ref($label) eq 'SCALAR';
+
+ # separate table / column (if applicable)
+ my $sep = $self->{name_sep} || '';
+ my @to_quote = $sep ? split /\Q$sep\E/, $label : ($label);
+
+ # do the quoting, except for "*" or for `table`.*
+ my @quoted = map { $_ eq '*' ? $_: $ql.$_.$qr} @to_quote;
+
+ # reassemble and return.
+ return join $sep, @quoted;
+}
+
+
+# Conversion, if applicable
+sub _convert ($) {
+ my ($self, $arg) = @_;
+
+# LDNOTE : modified the previous implementation below because
+# it was not consistent : the first "return" is always an array,
+# the second "return" is context-dependent. Anyway, _convert
+# seems always used with just a single argument, so make it a
+# scalar function.
+# return @_ unless $self->{convert};
+# my $conv = $self->_sqlcase($self->{convert});
+# my @ret = map { $conv.'('.$_.')' } @_;
+# return wantarray ? @ret : $ret[0];
+ if ($self->{convert}) {
+ my $conv = $self->_sqlcase($self->{convert});
+ $arg = $conv.'('.$arg.')';
+ }
+ return $arg;
+}
+
+# And bindtype
+sub _bindtype (@) {
+ my $self = shift;
+ my($col, @vals) = @_;
+
+ #LDNOTE : changed original implementation below because it did not make
+ # sense when bindtype eq 'columns' and @vals > 1.
+# return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
+
+ return $self->{bindtype} eq 'columns' ? map {[$col, $_]} @vals : @vals;
+}
+
+# Dies if any element of @bind is not in [colname => value] format
+# if bindtype is 'columns'.
+sub _assert_bindval_matches_bindtype {
+ my ($self, @bind) = @_;
+
+ if ($self->{bindtype} eq 'columns') {
+ foreach my $val (@bind) {
+ if (!defined $val || ref($val) ne 'ARRAY' || @$val != 2) {
+ die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+ }
+ }
+ }
+}
+
+sub _join_sql_clauses {
+ my ($self, $logic, $clauses_aref, $bind_aref) = @_;
+
+ if (@$clauses_aref > 1) {
+ my $join = " " . $self->_sqlcase($logic) . " ";
+ my $sql = '( ' . join($join, @$clauses_aref) . ' )';
+ return ($sql, @$bind_aref);
+ }
+ elsif (@$clauses_aref) {
+ return ($clauses_aref->[0], @$bind_aref); # no parentheses
+ }
+ else {
+ return (); # if no SQL, ignore @$bind_aref
+ }
+}
+
+
+# Fix SQL case, if so requested
+sub _sqlcase {
+ my $self = shift;
+
+ # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
+ # don't touch the argument ... crooked logic, but let's not change it!
+ return $self->{case} ? $_[0] : uc($_[0]);
+}
+
+
+#======================================================================
+# DISPATCHING FROM REFKIND
+#======================================================================
+
+sub _refkind {
+ my ($self, $data) = @_;
+ my $suffix = '';
+ my $ref;
+ my $n_steps = 0;
+
+ while (1) {
+ # blessed objects are treated like scalars
+ $ref = (blessed $data) ? '' : ref $data;
+ $n_steps += 1 if $ref;
+ last if $ref ne 'REF';
+ $data = $$data;
+ }
+
+ my $base = $ref || (defined $data ? 'SCALAR' : 'UNDEF');
+
+ return $base . ('REF' x $n_steps);
+}
+
+
+
+sub _try_refkind {
+ my ($self, $data) = @_;
+ my @try = ($self->_refkind($data));
+ push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
+ push @try, 'FALLBACK';
+ return @try;
+}
+
+sub _METHOD_FOR_refkind {
+ my ($self, $meth_prefix, $data) = @_;
+ my $method = first {$_} map {$self->can($meth_prefix."_".$_)}
+ $self->_try_refkind($data)
+ or puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
+ return $method;
+}
+
+
+sub _SWITCH_refkind {
+ my ($self, $data, $dispatch_table) = @_;
+
+ my $coderef = first {$_} map {$dispatch_table->{$_}}
+ $self->_try_refkind($data)
+ or puke "no dispatch entry for ".$self->_refkind($data);
+ $coderef->();
+}
+
+
+
+
+#======================================================================
+# VALUES, GENERATE, AUTOLOAD
+#======================================================================
+
+# LDNOTE: original code from nwiger, didn't touch code in that section
+# I feel the AUTOLOAD stuff should not be the default, it should
+# only be activated on explicit demand by user.
+
+sub values {
+ my $self = shift;
+ my $data = shift || return;
+ puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
+ unless ref $data eq 'HASH';
+
+ my @all_bind;
+ foreach my $k ( sort keys %$data ) {
+ my $v = $data->{$k};
+ $self->_SWITCH_refkind($v, {
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}) { # array datatype
+ push @all_bind, $self->_bindtype($k, $v);
+ }
+ else { # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @all_bind, @bind;
+ }
+ },
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @all_bind, @bind;
+ },
+ SCALARREF => sub { # literal SQL without bind
+ },
+ SCALAR_or_UNDEF => sub {
+ push @all_bind, $self->_bindtype($k, $v);
+ },
+ });
+ }
+
+ return @all_bind;
+}
+
+sub generate {
+ my $self = shift;
+
+ my(@sql, @sqlq, @sqlv);
+
+ for (@_) {
+ my $ref = ref $_;
+ if ($ref eq 'HASH') {
+ for my $k (sort keys %$_) {
+ my $v = $_->{$k};
+ my $r = ref $v;
+ my $label = $self->_quote($k);
+ if ($r eq 'ARRAY') {
+ # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @sqlq, "$label = $sql";
+ push @sqlv, @bind;
+ } elsif ($r eq 'SCALAR') {
+ # literal SQL without bind
+ push @sqlq, "$label = $$v";
+ } else {
+ push @sqlq, "$label = ?";
+ push @sqlv, $self->_bindtype($k, $v);
+ }
+ }
+ push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
+ } elsif ($ref eq 'ARRAY') {
+ # unlike insert(), assume these are ONLY the column names, i.e. for SQL
+ for my $v (@$_) {
+ my $r = ref $v;
+ if ($r eq 'ARRAY') { # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @sqlq, $sql;
+ push @sqlv, @bind;
+ } elsif ($r eq 'SCALAR') { # literal SQL without bind
+ # embedded literal SQL
+ push @sqlq, $$v;
+ } else {
+ push @sqlq, '?';
+ push @sqlv, $v;
+ }
+ }
+ push @sql, '(' . join(', ', @sqlq) . ')';
+ } elsif ($ref eq 'SCALAR') {
+ # literal SQL
+ push @sql, $$_;
+ } else {
+ # strings get case twiddled
+ push @sql, $self->_sqlcase($_);
+ }
+ }
+
+ my $sql = join ' ', @sql;
+
+ # this is pretty tricky
+ # if ask for an array, return ($stmt, @bind)
+ # otherwise, s/?/shift @sqlv/ to put it inline
+ if (wantarray) {
+ return ($sql, @sqlv);
+ } else {
+ 1 while $sql =~ s/\?/my $d = shift(@sqlv);
+ ref $d ? $d->[1] : $d/e;
+ return $sql;
+ }
+}
+
+
+sub DESTROY { 1 }
+
+sub AUTOLOAD {
+ # This allows us to check for a local, then _form, attr
+ my $self = shift;
+ my($name) = $AUTOLOAD =~ /.*::(.+)/;
+ return $self->generate($name, @_);
+}
+
+1;
+
+
+
+__END__
+
=head1 NAME
SQL::Abstract - Generate SQL from Perl data structures
@@ -74,14 +1191,37 @@
my $sth = $dbh->prepare($stmt);
$sth->execute(@bind);
-In addition, you can apply SQL functions to elements of your C<%data>
-by specifying an arrayref for the given hash value. For example, if
-you need to execute the Oracle C<to_date> function on a value, you
-can say something like this:
+=head2 Inserting and Updating Arrays
+If your database has array types (like for example Postgres),
+activate the special option C<< array_datatypes => 1 >>
+when creating the C<SQL::Abstract> object.
+Then you may use an arrayref to insert and update database array types:
+
+ my $sql = SQL::Abstract->new(array_datatypes => 1);
my %data = (
+ planets => [qw/Mercury Venus Earth Mars/]
+ );
+
+ my($stmt, @bind) = $sql->insert('solar_system', \%data);
+
+This results in:
+
+ $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
+
+ @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
+
+
+=head2 Inserting and Updating SQL
+
+In order to apply SQL functions to elements of your C<%data> you may
+specify a reference to an arrayref for the given hash value. For example,
+if you need to execute the Oracle C<to_date> function on a value, you can
+say something like this:
+
+ my %data = (
name => 'Bill',
- date_entered => ["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
+ date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
);
The first value in the array is the actual SQL. Any other values are
@@ -103,6 +1243,8 @@
want to specify a WHERE clause for your UPDATE, though, which is
where handling C<%where> hashes comes in handy...
+=head2 Complex where statements
+
This module can generate pretty complicated WHERE statements
easily. For example, simple C<key=value> pairs are taken to mean
equality, and if you want to see if a field is within a set
@@ -138,183 +1280,9 @@
similar order to each function (table, then fields, then a where
clause) to try and simplify things.
-=cut
-use Carp;
-use strict;
-our $VERSION = '1.23';
-#XXX don't understand this below, leaving it for someone else. did bump the $VERSION --groditi
-our $REVISION = '$Id$';
-our $AUTOLOAD;
-# Fix SQL case, if so requested
-sub _sqlcase {
- my $self = shift;
- return $self->{case} ? $_[0] : uc($_[0]);
-}
-
-# Anon copies of arrays/hashes
-# Based on deep_copy example by merlyn
-# http://www.stonehenge.com/merlyn/UnixReview/col30.html
-sub _anoncopy {
- my $orig = shift;
- return (ref $orig eq 'HASH') ? +{map { $_ => _anoncopy($orig->{$_}) } keys %$orig}
- : (ref $orig eq 'ARRAY') ? [map _anoncopy($_), @$orig]
- : $orig;
-}
-
-# Debug
-sub _debug {
- return unless $_[0]->{debug}; shift; # a little faster
- my $func = (caller(1))[3];
- warn "[$func] ", @_, "\n";
-}
-
-sub belch (@) {
- my($func) = (caller(1))[3];
- carp "[$func] Warning: ", @_;
-}
-
-sub puke (@) {
- my($func) = (caller(1))[3];
- croak "[$func] Fatal: ", @_;
-}
-
-# Utility functions
-sub _table {
- my $self = shift;
- my $from = shift;
- if (ref $from eq 'ARRAY') {
- return $self->_recurse_from(@$from);
- } elsif (ref $from eq 'HASH') {
- return $self->_make_as($from);
- } else {
- return $self->_quote($from);
- }
-}
-
-sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push(@sqlf, $self->_make_as($from));
- foreach my $j (@join) {
- push @sqlf, ', ' . $self->_quote($j) and next unless ref $j;
- push @sqlf, ', ' . $$j and next if ref $j eq 'SCALAR';
- my ($to, $on) = @$j;
-
- # check whether a join type exists
- my $join_clause = '';
- my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
- if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
- $join_clause = $self->_sqlcase(' '.($to_jt->{-join_type}).' JOIN ');
- } else {
- $join_clause = $self->_sqlcase(' JOIN ');
- }
- push(@sqlf, $join_clause);
-
- if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_make_as($to));
- }
- push(@sqlf, $self->_sqlcase(' ON '), $self->_join_condition($on));
- }
- return join('', @sqlf);
-}
-
-sub _make_as {
- my ($self, $from) = @_;
- return $self->_quote($from) unless ref $from;
- return $$from if ref $from eq 'SCALAR';
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
- reverse each %{$self->_skip_options($from)});
-}
-
-sub _skip_options {
- my ($self, $hash) = @_;
- my $clean_hash = {};
- $clean_hash->{$_} = $hash->{$_}
- for grep {!/^-/} keys %$hash;
- return $clean_hash;
-}
-
-sub _join_condition {
- my ($self, $cond) = @_;
- if (ref $cond eq 'HASH') {
- my %j;
- for (keys %$cond) {
- my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
- };
- return $self->_recurse_where(\%j);
- } elsif (ref $cond eq 'ARRAY') {
- return join(' OR ', map { $self->_join_condition($_) } @$cond);
- } else {
- die "Can't handle this yet!";
- }
-}
-
-
-sub _quote {
- my $self = shift;
- my $label = shift;
-
- return '' unless defined $label;
-
- return $label
- if $label eq '*';
-
- return $$label if ref($label) eq 'SCALAR';
-
- return $label unless $self->{quote_char};
-
- if (ref $self->{quote_char} eq "ARRAY") {
-
- return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
- if !defined $self->{name_sep};
-
- my $sep = $self->{name_sep};
- return join($self->{name_sep},
- map { $_ eq '*'
- ? $_
- : $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
- split( /\Q$sep\E/, $label ) );
- }
-
-
- return $self->{quote_char} . $label . $self->{quote_char}
- if !defined $self->{name_sep};
-
- return join $self->{name_sep},
- map { $_ eq '*' ? $_ : $self->{quote_char} . $_ . $self->{quote_char} }
- split /\Q$self->{name_sep}\E/, $label;
-}
-
-# Conversion, if applicable
-sub _convert ($) {
- my $self = shift;
- return @_ unless $self->{convert};
- my $conv = $self->_sqlcase($self->{convert});
- my @ret = map { $conv.'('.$_.')' } @_;
- return wantarray ? @ret : $ret[0];
-}
-
-# And bindtype
-sub _bindtype (@) {
- my $self = shift;
- my($col, at val) = @_;
- return $self->{bindtype} eq 'columns' ? [ @_ ] : @val;
-}
-
-# Modified -logic or -nest
-sub _modlogic ($) {
- my $self = shift;
- my $sym = @_ ? lc(shift) : $self->{logic};
- $sym =~ tr/_/ /;
- $sym = $self->{logic} if $sym eq 'nest';
- return $self->_sqlcase($sym); # override join
-}
-
=head2 new(option => 'value')
The C<new()> function takes a list of options and values, and returns
@@ -330,6 +1298,8 @@
SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
+Any setting other than 'lower' is ignored.
+
=item cmp
This determines what the default comparison operator is. By default
@@ -349,6 +1319,11 @@
You can also override the comparsion on an individual basis - see
the huge section on L</"WHERE CLAUSES"> at the bottom.
+=item sqltrue, sqlfalse
+
+Expressions for inserting boolean values within SQL statements.
+By default these are C<1=1> and C<1=0>.
+
=item logic
This determines the default logical operator for multiple WHERE
@@ -373,6 +1348,14 @@
WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
+The logic can also be changed locally by inserting
+an extra first element in the array :
+
+ @where = (-and => event_date => {'>=', '2/13/99'},
+ event_date => {'<=', '4/24/03'} );
+
+See the L</"WHERE CLAUSES"> section for explanations.
+
=item convert
This will automatically convert comparisons using the specified SQL
@@ -417,7 +1400,7 @@
);
You can then iterate through this manually, using DBI's C<bind_param()>.
-
+
$sth->prepare($stmt);
my $i = 1;
for (@bind) {
@@ -439,6 +1422,10 @@
sub called C<bind_fields()> or something and reuse it repeatedly. You still
get a layer of abstraction over manual SQL specification.
+Note that if you set L</bindtype> to C<columns>, the C<\[$sql, @bind]>
+construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
+will expect the bind values in this format.
+
=item quote_char
This is the character that a table or column name will be quoted
@@ -447,9 +1434,16 @@
SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
-This is useful if you have tables or columns that are reserved words
-in your database's SQL dialect.
+Alternatively, you can supply an array ref of two items, the first being the left
+hand quote character, and the second the right hand quote character. For
+example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
+that generates SQL like this:
+ SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
+
+Quoting is useful if you have tables or columns names that are reserved
+words in your database's SQL dialect.
+
=item name_sep
This is the character that separates a table and column name. It is
@@ -458,200 +1452,94 @@
SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
-=back
+=item array_datatypes
-=cut
+When this option is true, arrayrefs in INSERT or UPDATE are
+interpreted as array datatypes and are passed directly
+to the DBI layer.
+When this option is false, arrayrefs are interpreted
+as literal SQL, just like refs to arrayrefs
+(but this behavior is for backwards compatibility; when writing
+new queries, use the "reference to arrayref" syntax
+for literal SQL).
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
- # choose our case by keeping an option around
- delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
+=item special_ops
- # override logical operator
- $opt{logic} = uc $opt{logic} if $opt{logic};
+Takes a reference to a list of "special operators"
+to extend the syntax understood by L<SQL::Abstract>.
+See section L</"SPECIAL OPERATORS"> for details.
- # how to return bind vars
- $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
- # default comparison is "=", but can be overridden
- $opt{cmp} ||= '=';
- # default quotation character around tables/columns
- $opt{quote_char} ||= '';
+=back
- return bless \%opt, $class;
-}
-
=head2 insert($table, \@values || \%fieldvals)
This is the simplest function. You simply give it a table name
and either an arrayref of values or hashref of field/value pairs.
It returns an SQL INSERT statement and a list of bind values.
+See the sections on L</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> for information on how to insert
+with those data types.
-=cut
-
-sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
-
- my $sql = $self->_sqlcase('insert into') . " $table ";
- my(@sqlf, @sqlv, @sqlq) = ();
-
- my $ref = ref $data;
- if ($ref eq 'HASH') {
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- # named fields, so must save names in order
- push @sqlf, $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, $self->_bindtype($k, @val);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- $sql .= '(' . join(', ', @sqlf) .') '. $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
- } elsif ($ref eq 'ARRAY') {
- # just generate values(?,?) part
- # no names (arrayref) so can't generate bindtype
- carp "Warning: ",__PACKAGE__,"->insert called with arrayref when bindtype set"
- if $self->{bindtype} ne 'normal';
- for my $v (@$data) {
- my $r = ref $v;
- if ($r eq 'ARRAY') {
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, @val;
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $v;
- }
- }
- $sql .= $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
- } elsif ($ref eq 'SCALAR') {
- # literal SQL
- $sql .= $$data;
- } else {
- puke "Unsupported data type specified to \$sql->insert";
- }
-
- return wantarray ? ($sql, @sqlv) : $sql;
-}
-
=head2 update($table, \%fieldvals, \%where)
This takes a table, hashref of field/value pairs, and an optional
hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
of bind values.
+See the sections on L</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> for information on how to insert
+with those data types.
-=cut
+=head2 select($source, $fields, $where, $order)
-sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
+This returns a SQL SELECT statement and associated list of bind values, as
+specified by the arguments :
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ');
- my(@sqlf, @sqlv) = ();
+=over
- puke "Unsupported data type specified to \$sql->update"
- unless ref $data eq 'HASH';
+=item $source
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @bind = @$v;
- my $sql = shift @bind;
- push @sqlf, "$label = $sql";
- push @sqlv, $self->_bindtype($k, @bind);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlf, "$label = $$v";
- } else {
- push @sqlf, "$label = ?";
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
+Specification of the 'FROM' part of the statement.
+The argument can be either a plain scalar (interpreted as a table
+name, will be quoted), or an arrayref (interpreted as a list
+of table names, joined by commas, quoted), or a scalarref
+(literal table name, not quoted), or a ref to an arrayref
+(list of literal table names, joined by commas, not quoted).
- $sql .= join ', ', @sqlf;
+=item $fields
- if ($where) {
- my($wsql, @wval) = $self->where($where);
- $sql .= $wsql;
- push @sqlv, @wval;
- }
+Specification of the list of fields to retrieve from
+the source.
+The argument can be either an arrayref (interpreted as a list
+of field names, will be joined by commas and quoted), or a
+plain scalar (literal SQL, not quoted).
+Please observe that this API is not as flexible as for
+the first argument C<$table>, for backwards compatibility reasons.
- return wantarray ? ($sql, @sqlv) : $sql;
-}
+=item $where
-=head2 select($table, \@fields, \%where, \@order)
+Optional argument to specify the WHERE part of the query.
+The argument is most often a hashref, but can also be
+an arrayref or plain scalar --
+see section L<WHERE clause|/"WHERE CLAUSES"> for details.
-This takes a table, arrayref of fields (or '*'), optional hashref
-L<WHERE clause|/WHERE CLAUSES>, and optional array or hash ref L<ORDER BY clause|/ORDER BY CLAUSES>, and returns the
-corresponding SQL SELECT statement and list of bind values.
+=item $order
-=cut
+Optional argument to specify the ORDER BY part of the query.
+The argument can be a scalar, a hashref or an arrayref
+-- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
+for details.
-sub select {
- my $self = shift;
- my $table = $self->_table(shift);
- my $fields = shift || '*';
- my $where = shift;
- my $order = shift;
+=back
- my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields : $fields;
- my $sql = join ' ', $self->_sqlcase('select'), $f, $self->_sqlcase('from'), $table;
- my(@sqlf, @sqlv) = ();
- my($wsql, @wval) = $self->where($where, $order);
- $sql .= $wsql;
- push @sqlv, @wval;
-
- return wantarray ? ($sql, @sqlv) : $sql;
-}
-
=head2 delete($table, \%where)
This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
It returns an SQL DELETE statement and list of bind values.
-=cut
-
-sub delete {
- my $self = shift;
- my $table = $self->_table(shift);
- my $where = shift;
-
- my $sql = $self->_sqlcase('delete from') . " $table";
- my(@sqlf, @sqlv) = ();
-
- if ($where) {
- my($wsql, @wval) = $self->where($where);
- $sql .= $wsql;
- push @sqlv, @wval;
- }
-
- return wantarray ? ($sql, @sqlv) : $sql;
-}
-
=head2 where(\%where, \@order)
This is used to generate just the WHERE clause. For example,
@@ -660,248 +1548,7 @@
to produce a WHERE clause, use this. It returns an SQL WHERE
clause and list of bind values.
-=cut
-# Finally, a separate routine just to handle WHERE clauses
-sub where {
- my $self = shift;
- my $where = shift;
- my $order = shift;
-
- # Need a separate routine to properly wrap w/ "where"
- my $sql = '';
- my @ret = $self->_recurse_where($where);
- if (@ret) {
- my $wh = shift @ret;
- $sql .= $self->_sqlcase(' where ') . $wh if $wh;
- }
-
- # order by?
- if ($order) {
- $sql .= $self->_order_by($order);
- }
-
- return wantarray ? ($sql, @ret) : $sql;
-}
-
-
-sub _recurse_where {
- local $^W = 0; # really, you've gotta be fucking kidding me
- my $self = shift;
- my $where = _anoncopy(shift); # prevent destroying original
- my $ref = ref $where || '';
- my $join = shift || $self->{logic} ||
- ($ref eq 'ARRAY' ? $self->_sqlcase('or') : $self->_sqlcase('and'));
-
- # For assembling SQL fields and values
- my(@sqlf, @sqlv) = ();
-
- # If an arrayref, then we join each element
- if ($ref eq 'ARRAY') {
- # need to use while() so can shift() for arrays
- my $subjoin;
- while (my $el = shift @$where) {
-
- # skip empty elements, otherwise get invalid trailing AND stuff
- if (my $ref2 = ref $el) {
- if ($ref2 eq 'ARRAY') {
- next unless @$el;
- } elsif ($ref2 eq 'HASH') {
- next unless %$el;
- $subjoin ||= $self->_sqlcase('and');
- } elsif ($ref2 eq 'SCALAR') {
- # literal SQL
- push @sqlf, $$el;
- next;
- }
- $self->_debug("$ref2(*top) means join with $subjoin");
- } else {
- # top-level arrayref with scalars, recurse in pairs
- $self->_debug("NOREF(*top) means join with $subjoin");
- $el = {$el => shift(@$where)};
- }
- my @ret = $self->_recurse_where($el, $subjoin);
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- }
- }
- elsif ($ref eq 'HASH') {
- # Note: during recursion, the last element will always be a hashref,
- # since it needs to point a column => value. So this be the end.
- for my $k (sort keys %$where) {
- my $v = $where->{$k};
- my $label = $self->_quote($k);
-
- if ($k =~ /^-(\D+)/) {
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = $self->_modlogic($1);
- $self->_debug("OP(-$1) means special logic ($subjoin), recursing...");
- my @ret = $self->_recurse_where($v, $subjoin);
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- } elsif (! defined($v)) {
- # undef = null
- $self->_debug("UNDEF($k) means IS NULL");
- push @sqlf, $label . $self->_sqlcase(' is null');
- } elsif (ref $v eq 'ARRAY') {
- if( @$v ) {
- my @v = @$v;
- # multiple elements: multiple options
- $self->_debug("ARRAY($k) means multiple elements: [ @v ]");
-
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = $self->_sqlcase('or');
- if ($v[0] =~ /^-(\D+)/) {
- $subjoin = $self->_modlogic($1); # override subjoin
- $self->_debug("OP(-$1) means special logic ($subjoin), shifting...");
- shift @v;
- }
-
- # map into an array of hashrefs and recurse
- my @ret = $self->_recurse_where([map { {$k => $_} } @v], $subjoin);
-
- # push results into our structure
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- } else {
- $self->_debug("empty ARRAY($k) means 0=1");
- push @sqlf, '0=1';
- }
- } elsif (ref $v eq 'HASH') {
- # modified operator { '!=', 'completed' }
- for my $f (sort keys %$v) {
- my $x = $v->{$f};
-
- # do the right thing for single -in values
- $x = [$x] if ($f =~ /^-?\s*(not[\s_]+)?in\s*$/i && ref $x ne 'ARRAY');
-
- $self->_debug("HASH($k) means modified operator: { $f }");
-
- # check for the operator being "IN" or "BETWEEN" or whatever
- if (ref $x eq 'ARRAY') {
- if ($f =~ /^-?\s*(not[\s_]+)?(in|between)\s*$/i) {
- my $u = $self->_modlogic($1 . $2);
- $self->_debug("HASH($f => $x) uses special operator: [ $u ]");
- if ($u =~ /between/i) {
- # SQL sucks
- # Throw an exception if you try to use between with
- # anything other than 2 values
- $self->puke("You need two values to use between") unless @$x == 2;
- push @sqlf, join ' ', $self->_convert($label), $u, $self->_convert('?'),
- $self->_sqlcase('and'), $self->_convert('?');
- } elsif (@$x) {
- # DWIM for empty arrayrefs
- push @sqlf, join ' ', $self->_convert($label), $u, '(',
- join(', ', map { $self->_convert('?') } @$x),
- ')';
- } elsif(@$x == 0){
- # Empty IN defaults to 0=1 and empty NOT IN to 1=1
- push(@sqlf, ($u =~ /not/i ? "1=1" : "0=1"));
- }
- push @sqlv, $self->_bindtype($k, @$x);
- } elsif(@$x) {
- # multiple elements: multiple options
- $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
- # map into an array of hashrefs and recurse
- my @ret = $self->_recurse_where([map { {$k => {$f, $_}} } @$x]);
-
- # push results into our structure
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- } else {
- #DTRT for $op => []
- # I feel like <= and >= should resolve to 0=1 but I am not sure.
- if($f eq '='){
- push @sqlf, '0=1';
- } elsif( $f eq '!='){
- push @sqlf, '1=1';
- } else {
- $self->puke("Can not generate SQL for '${f}' comparison of '${k}' using empty array");
- }
- }
- } elsif (! defined($x)) {
- # undef = NOT null
- my $not = ($f eq '!=' || $f eq 'not like') ? ' not' : '';
- push @sqlf, $label . $self->_sqlcase(" is$not null");
- } else {
- # regular ol' value
- $f =~ s/^-//; # strip leading -like =>
- $f =~ s/_/ /; # _ => " "
- push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($f), $self->_convert('?');
- push @sqlv, $self->_bindtype($k, $x);
- }
- }
- } elsif (ref $v eq 'SCALAR') {
- # literal SQL
- $self->_debug("SCALAR($k) means literal SQL: $$v");
- push @sqlf, "$label $$v";
- } else {
- # standard key => val
- $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
- push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($self->{cmp}), $self->_convert('?');
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- }
- elsif ($ref eq 'SCALAR') {
- # literal sql
- $self->_debug("SCALAR(*top) means literal SQL: $$where");
- push @sqlf, $$where;
- }
- elsif (defined $where) {
- # literal sql
- $self->_debug("NOREF(*top) means literal SQL: $where");
- push @sqlf, $where;
- }
-
- # assemble and return sql
- my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '';
- return wantarray ? ($wsql, @sqlv) : $wsql;
-}
-
-sub _order_by {
- my $self = shift;
- my $ref = ref $_[0] || '';
-
- my $_order_hash = sub {
- local *__ANON__ = '_order_by_hash';
- my ($col, $order);
- my $hash = shift; # $_ was failing in some cases for me --groditi
- if ( $col = $hash->{'-desc'} ) {
- $order = 'DESC'
- } elsif ( $col = $hash->{'-asc'} ) {
- $order = 'ASC';
- } else {
- puke "Hash must have a key of '-desc' or '-asc' for ORDER BY";
- }
- return $self->_quote($col) . " $order";
-
- };
-
- my @vals;
- if ($ref eq 'ARRAY') {
- foreach (@{ $_[0] }) {
- my $ref = ref $_;
- if (!$ref || $ref eq 'SCALAR') {
- push @vals, $self->_quote($_);
- } elsif ($ref eq 'HASH') {
- push @vals, $_order_hash->($_);
- } else {
- puke "Unsupported nested data struct $ref for ORDER BY";
- }
- }
- } elsif ($ref eq 'HASH') {
- push @vals, $_order_hash->($_[0]);
- } elsif (!$ref || $ref eq 'SCALAR') {
- push @vals, $self->_quote($_[0]);
- } else {
- puke "Unsupported data struct $ref for ORDER BY";
- }
-
- my $val = join ', ', @vals;
- return $val ? $self->_sqlcase(' order by')." $val" : '';
-}
-
=head2 values(\%data)
This just returns the values from the hash C<%data>, in the same
@@ -909,16 +1556,6 @@
Using this allows you to markedly speed up your queries if you
are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
-=cut
-
-sub values {
- my $self = shift;
- my $data = shift || return;
- puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
- unless ref $data eq 'HASH';
- return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data;
-}
-
=head2 generate($any, 'number', $of, \@data, $struct, \%types)
Warning: This is an experimental method and subject to change.
@@ -952,89 +1589,13 @@
You get the idea. Strings get their case twiddled, but everything
else remains verbatim.
-=cut
-sub generate {
- my $self = shift;
- my(@sql, @sqlq, @sqlv);
- for (@_) {
- my $ref = ref $_;
- if ($ref eq 'HASH') {
- for my $k (sort keys %$_) {
- my $v = $_->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @bind = @$v;
- my $sql = shift @bind;
- push @sqlq, "$label = $sql";
- push @sqlv, $self->_bindtype($k, @bind);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, "$label = $$v";
- } else {
- push @sqlq, "$label = ?";
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
- } elsif ($ref eq 'ARRAY') {
- # unlike insert(), assume these are ONLY the column names, i.e. for SQL
- for my $v (@$_) {
- my $r = ref $v;
- if ($r eq 'ARRAY') {
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, @val;
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $v;
- }
- }
- push @sql, '(' . join(', ', @sqlq) . ')';
- } elsif ($ref eq 'SCALAR') {
- # literal SQL
- push @sql, $$_;
- } else {
- # strings get case twiddled
- push @sql, $self->_sqlcase($_);
- }
- }
+=head1 WHERE CLAUSES
- my $sql = join ' ', @sql;
+=head2 Introduction
- # this is pretty tricky
- # if ask for an array, return ($stmt, @bind)
- # otherwise, s/?/shift @sqlv/ to put it inline
- if (wantarray) {
- return ($sql, @sqlv);
- } else {
- 1 while $sql =~ s/\?/my $d = shift(@sqlv);
- ref $d ? $d->[1] : $d/e;
- return $sql;
- }
-}
-
-sub DESTROY { 1 }
-sub AUTOLOAD {
- # This allows us to check for a local, then _form, attr
- my $self = shift;
- my($name) = $AUTOLOAD =~ /.*::(.+)/;
- return $self->generate($name, @_);
-}
-
-1;
-
-__END__
-
-=head1 WHERE CLAUSES
-
This module uses a variation on the idea from L<DBIx::Abstract>. It
is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
module is that things in arrays are OR'ed, and things in hashes
@@ -1048,6 +1609,8 @@
However, note that the C<%where> hash can be used directly in any
of the other functions as well, as described above.
+=head2 Key-value pairs
+
So, let's get started. To begin, a simple hash:
my %where = (
@@ -1074,9 +1637,11 @@
$stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
@bind = ('nwiger', 'assigned', 'in-progress', 'pending');
-Please note that an empty arrayref will be considered a logical false and
+An empty arrayref will be considered a logical false and
will generate 0=1.
+=head2 Key-value pairs
+
If you want to specify a different type of operator for your comparison,
you can use a hashref for a given column:
@@ -1094,15 +1659,22 @@
status => { '!=', ['assigned', 'in-progress', 'pending'] };
-An empty arrayref will try to Do The Right Thing for the operators '=', '!=',
-'-in' '-not_in', but will throw an exception for everything else.
-
Which would give you:
- "WHERE status != ? OR status != ? OR status != ?"
+ "WHERE status != ? AND status != ? AND status != ?"
-But, this is probably not what you want in this case (look at it). So
-the hashref can also contain multiple pairs, in which case it is expanded
+Notice that since the operator was recognized as being a 'negative'
+operator, the arrayref was interpreted with 'AND' logic (because
+of Morgan's laws). By contrast, the reverse
+
+ status => { '=', ['assigned', 'in-progress', 'pending'] };
+
+would generate :
+
+ "WHERE status = ? OR status = ? OR status = ?"
+
+
+The hashref can also contain multiple pairs, in which case it is expanded
into an C<AND> of its elements:
my %where = (
@@ -1119,6 +1691,7 @@
$stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
@bind = ('nwiger', 'completed', 'pending%');
+
To get an OR instead, you can combine it with the arrayref idea:
my %where => (
@@ -1131,7 +1704,24 @@
$stmt = "WHERE user = ? AND priority = ? OR priority != ?";
@bind = ('nwiger', '2', '1');
-However, there is a subtle trap if you want to say something like
+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,
+there is a subtle trap if you want to say something like
this (notice the C<AND>):
WHERE priority != ? AND priority != ?
@@ -1143,8 +1733,10 @@
As the second C<!=> key will obliterate the first. The solution
is to use the special C<-modifier> form inside an arrayref:
- priority => [ -and => {'!=', 2}, {'!=', 1} ]
+ priority => [ -and => {'!=', 2},
+ {'!=', 1} ]
+
Normally, these would be joined by C<OR>, but the modifier tells it
to use C<AND> instead. (Hint: You can use this in conjunction with the
C<logic> option to C<new()> in order to change the way your queries
@@ -1179,6 +1771,19 @@
-nest => [ workhrs => {'>', 20}, geo => 'ASIA' ],
);
+If you need several nested subexpressions, you can number
+the C<-nest> branches :
+
+ my %where = (
+ user => 'nwiger',
+ -nest1 => ...,
+ -nest2 => ...,
+ ...
+ );
+
+
+=head2 Special operators : IN, BETWEEN, etc.
+
You can also use the hashref format to compare a list of fields using the
C<IN> comparison operator, by specifying the list as an arrayref:
@@ -1192,9 +1797,12 @@
$stmt = "WHERE status = ? AND reportid IN (?,?,?)";
@bind = ('completed', '567', '2335', '2');
-You can use this same format to use other grouping functions, such
-as C<BETWEEN>, C<SOME>, and so forth. For example:
+The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
+the same way.
+Another pair of operators is C<-between> and C<-not_between>,
+used with an arrayref of two values:
+
my %where = (
user => 'nwiger',
completion_date => {
@@ -1206,6 +1814,11 @@
WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
+These are the two builtin "special operators"; but the
+list can be expanded : see section L</"SPECIAL OPERATORS"> below.
+
+=head2 Nested conditions
+
So far, we've seen how multiple conditions are joined with a top-level
C<AND>. We can change this by putting the different conditions we want in
hashes and then putting those hashes in an array. For example:
@@ -1234,8 +1847,8 @@
-and => [
user => 'nwiger',
-nest => [
- -and => [workhrs => {'>', 20}, geo => 'ASIA' ],
- -and => [workhrs => {'<', 50}, geo => 'EURO' ]
+ ["-and", workhrs => {'>', 20}, geo => 'ASIA' ],
+ ["-and", workhrs => {'<', 50}, geo => 'EURO' ]
],
],
);
@@ -1246,6 +1859,8 @@
( ( workhrs > ? AND geo = ? )
OR ( workhrs < ? AND geo = ? ) ) )
+=head2 Literal SQL
+
Finally, sometimes only literal SQL will do. If you want to include
literal SQL verbatim, you can specify it as a scalar reference, namely:
@@ -1271,8 +1886,134 @@
requestor => { '!=', undef },
);
+
TMTOWTDI.
+Conditions on boolean columns can be expressed in the
+same way, passing a reference to an empty string :
+
+ my %where = (
+ priority => { '<', 2 },
+ is_ready => \"";
+ );
+
+which yields
+
+ $stmt = "WHERE priority < ? AND is_ready";
+ @bind = ('2');
+
+
+=head2 Literal SQL with placeholders and bind values (subqueries)
+
+If the literal SQL to be inserted has placeholders and bind values,
+use a reference to an arrayref (yes this is a double reference --
+not so common, but perfectly legal Perl). For example, to find a date
+in Postgres you can use something like this:
+
+ my %where = (
+ date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
+ )
+
+This would create:
+
+ $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
+ @bind = ('10');
+
+Note that you must pass the bind values in the same format as they are returned
+by L</where>. That means that if you set L</bindtype> to C<columns>, you must
+provide the bind values in the C<< [ column_meta => value ] >> format, where
+C<column_meta> is an opaque scalar value; most commonly the column name, but
+you can use any scalar value (including references and blessed references),
+L<SQL::Abstract> will simply pass it through intact. So if C<bindtype> is set
+to C<columns> the above example will look like:
+
+ my %where = (
+ date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/]
+ )
+
+Literal SQL is especially useful for nesting parenthesized clauses in the
+main SQL query. Here is a first example :
+
+ my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+ my %where = (
+ foo => 1234,
+ bar => \["IN ($sub_stmt)" => @sub_bind],
+ );
+
+This yields :
+
+ $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
+ WHERE c2 < ? AND c3 LIKE ?))";
+ @bind = (1234, 100, "foo%");
+
+Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">,
+are expressed in the same way. Of course the C<$sub_stmt> and
+its associated bind values can be generated through a former call
+to C<select()> :
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->select("t1", "c1", {c2 => {"<" => 100},
+ c3 => {-like => "foo%"}});
+ my %where = (
+ foo => 1234,
+ bar => \["> ALL ($sub_stmt)" => @sub_bind],
+ );
+
+In the examples above, the subquery was used as an operator on a column;
+but the same principle also applies for a clause within the main C<%where>
+hash, like an EXISTS subquery :
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
+ my %where = (
+ foo => 1234,
+ -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
+ );
+
+which yields
+
+ $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1
+ WHERE c1 = ? AND c2 > t0.c0))";
+ @bind = (1234, 1);
+
+
+Observe that the condition on C<c2> in the subquery refers to
+column C<t0.c0> of the main query : this is I<not> a bind
+value, so we have to express it through a scalar ref.
+Writing C<< c2 => {">" => "t0.c0"} >> would have generated
+C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
+what we wanted here.
+
+Another use of the subquery technique is when some SQL clauses need
+parentheses, as it often occurs with some proprietary SQL extensions
+like for example fulltext expressions, geospatial expressions,
+NATIVE clauses, etc. Here is an example of a fulltext query in MySQL :
+
+ my %where = (
+ -nest => \["MATCH (col1, col2) AGAINST (?)" => qw/apples/]
+ );
+
+Finally, here is an example where a subquery is used
+for expressing unary negation:
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->where({age => [{"<" => 10}, {">" => 20}]});
+ $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
+ my %where = (
+ lname => {like => '%son%'},
+ -nest => \["NOT ($sub_stmt)" => @sub_bind],
+ );
+
+This yields
+
+ $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
+ @bind = ('%son%', 10, 20)
+
+
+
+=head2 Conclusion
+
These pages could go on for a while, since the nesting of the data
structures this module can handle are pretty much unlimited (the
module implements the C<WHERE> expansion as a recursive function
@@ -1286,6 +2027,9 @@
dynamically-generating SQL and could just hardwire it into your
script.
+
+
+
=head1 ORDER BY CLAUSES
Some functions take an order by clause. This can either be a scalar (just a
@@ -1306,6 +2050,73 @@
[colA => {-asc => 'colB'}] | ORDER BY colA, colB ASC
==========================================================
+
+
+=head1 SPECIAL OPERATORS
+
+ my $sqlmaker = SQL::Abstract->new(special_ops => [
+ {regex => qr/.../,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ ...
+ },
+ },
+ ]);
+
+A "special operator" is a SQL syntactic clause that can be
+applied to a field, instead of a usual binary operator.
+For example :
+
+ WHERE field IN (?, ?, ?)
+ WHERE field BETWEEN ? AND ?
+ WHERE MATCH(field) AGAINST (?, ?)
+
+Special operators IN and BETWEEN are fairly standard and therefore
+are builtin within C<SQL::Abstract>. For other operators,
+like the MATCH .. AGAINST example above which is
+specific to MySQL, you can write your own operator handlers :
+supply a C<special_ops> argument to the C<new> method.
+That argument takes an arrayref of operator definitions;
+each operator definition is a hashref with two entries
+
+=over
+
+=item regex
+
+the regular expression to match the operator
+
+=item handler
+
+coderef that will be called when meeting that operator
+in the input tree. The coderef will be called with
+arguments C<< ($self, $field, $op, $arg) >>, and
+should return a C<< ($sql, @bind) >> structure.
+
+=back
+
+For example, here is an implementation
+of the MATCH .. AGAINST syntax for MySQL
+
+ my $sqlmaker = SQL::Abstract->new(special_ops => [
+
+ # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
+ {regex => qr/^match$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg = [$arg] if not ref $arg;
+ my $label = $self->_quote($field);
+ my ($placeholder) = $self->_convert('?');
+ my $placeholders = join ", ", (($placeholder) x @$arg);
+ my $sql = $self->_sqlcase('match') . " ($label) "
+ . $self->_sqlcase('against') . " ($placeholders) ";
+ my @bind = $self->_bindtype($field, @$arg);
+ return ($sql, @bind);
+ }
+ },
+
+ ]);
+
+
=head1 PERFORMANCE
Thanks to some benchmarking by Mark Stosberg, it turns out that
@@ -1331,6 +2142,7 @@
around. On subsequent queries, simply use the C<values> function provided
by this module to return your values in the correct order.
+
=head1 FORMBUILDER
If you use my C<CGI::FormBuilder> module at all, you'll hopefully
@@ -1360,27 +2172,82 @@
use these three modules together to write complex database query
apps in under 50 lines.
-=head1 NOTES
-There is not (yet) any explicit support for SQL compound logic
-statements like "AND NOT". Instead, just do the de Morgan's
-law transformations yourself. For example, this:
+=head1 CHANGES
- "lname LIKE '%son%' AND NOT ( age < 10 OR age > 20 )"
+Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
+Great care has been taken to preserve the I<published> behavior
+documented in previous versions in the 1.* family; however,
+some features that were previously undocumented, or behaved
+differently from the documentation, had to be changed in order
+to clarify the semantics. Hence, client code that was relying
+on some dark areas of C<SQL::Abstract> v1.*
+B<might behave differently> in v1.50.
-Becomes:
+The main changes are :
- "lname LIKE '%son%' AND ( age >= 10 AND age <= 20 )"
+=over
-With the corresponding C<%where> hash:
+=item *
- %where = (
- lname => {like => '%son%'},
- age => [-and => {'>=', 10}, {'<=', 20}],
- );
+support for literal SQL through the C<< \ [$sql, bind] >> syntax.
-Again, remember that the C<-and> goes I<inside> the arrayref.
+=item *
+support for the { operator => \"..." } construct (to embed literal SQL)
+
+=item *
+
+support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
+
+=item *
+
+added -nest1, -nest2 or -nest_1, -nest_2, ...
+
+=item *
+
+optional support for L<array datatypes|/"Inserting and Updating Arrays">
+
+=item *
+
+defensive programming : check arguments
+
+=item *
+
+fixed bug with global logic, which was previously implemented
+through global variables yielding side-effects. Prior versons would
+interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
+as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
+Now this is interpreted
+as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
+
+=item *
+
+C<-and> / C<-or> operators are no longer accepted
+in the middle of an arrayref : they are
+only admitted if in first position.
+
+=item *
+
+changed logic for distributing an op over arrayrefs
+
+=item *
+
+fixed semantics of _bindtype on array args
+
+=item *
+
+dropped the C<_anoncopy> of the %where tree. No longer necessary,
+we just avoid shifting arrays within that tree.
+
+=item *
+
+dropped the C<_modlogic> function
+
+=back
+
+
+
=head1 ACKNOWLEDGEMENTS
There are a number of individuals that have really helped out with
@@ -1396,6 +2263,8 @@
Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
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/trunk/t/00new.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/00new.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/00new.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -4,16 +4,20 @@
use warnings;
use Test::More;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
-plan tests => 15;
+#LDNOTE: renamed all "bind" into "where" because that's what they are
-use_ok('SQL::Abstract');
-
my @handle_tests = (
#1
{
args => {logic => 'OR'},
- stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )'
+# stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )'
+# LDNOTE: modified the line above (changing the test suite!!!) because
+# the test was not consistent with the doc: hashrefs should not be
+# influenced by the current logic, they always mean 'AND'. So
+# { a => 4, b => 0} should ALWAYS mean ( a = ? AND b = ? ).
+ stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )'
},
#2
{
@@ -33,7 +37,9 @@
#5
{
args => {cmp => "=", logic => 'or'},
- stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )'
+# LDNOTE idem
+# stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )'
+ stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )'
},
#6
{
@@ -43,7 +49,9 @@
#7
{
args => {logic => "or", cmp => "like"},
- stmt => 'SELECT * FROM test WHERE ( a LIKE ? OR b LIKE ? )'
+# LDNOTE idem
+# stmt => 'SELECT * FROM test WHERE ( a LIKE ? OR b LIKE ? )'
+ stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )'
},
#8
{
@@ -74,25 +82,45 @@
{
args => {convert => "lower"},
stmt => 'SELECT * FROM test WHERE ( ( LOWER(ticket) = LOWER(?) ) OR ( LOWER(hostname) = LOWER(?) ) OR ( LOWER(taco) = LOWER(?) ) OR ( LOWER(salami) = LOWER(?) ) )',
- bind => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ],
+ where => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ],
},
#14
{
args => {convert => "upper"},
- stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )',
- bind => [ { ticket => [11, 12, 13], hostname => { in => ['ntf', 'avd', 'bvd', '123'] } },
+# LDNOTE : modified the test below, because modified the semantics
+# of "e => { '!=', [qw(f g)] }" : generating "e != 'f' OR e != 'g'"
+# is nonsense (will always be true whatever the value of e). Since
+# this is a 'negative' operator, we must apply the Morgan laws and
+# interpret it as "e != 'f' AND e != 'g'" (and actually the user
+# should rather write "e => {-not_in => [qw/f g/]}".
+
+# stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )',
+ stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) AND ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )',
+ where => [ { ticket => [11, 12, 13],
+ hostname => { in => ['ntf', 'avd', 'bvd', '123'] } },
{ tack => { between => [qw/tick tock/] } },
- { a => [qw/b c d/], e => { '!=', [qw(f g)] }, q => { 'not in', [14..20] } } ],
+ { a => [qw/b c d/],
+ e => { '!=', [qw(f g)] },
+ q => { 'not in', [14..20] } } ],
},
);
+
+plan tests => (1 + scalar(@handle_tests));
+
+use_ok('SQL::Abstract');
+
for (@handle_tests) {
- local $" = ', ';
- #print "creating a handle with args ($_->{args}): ";
- my $sql = SQL::Abstract->new($_->{args});
- my $bind = $_->{bind} || { a => 4, b => 0};
- my($stmt, @bind) = $sql->select('test', '*', $bind);
- ok($stmt eq $_->{stmt} && @bind);
+ local $" = ', ';
+ #print "creating a handle with args ($_->{args}): ";
+ my $sql = SQL::Abstract->new($_->{args});
+ my $where = $_->{where} || { a => 4, b => 0};
+ my($stmt, @bind) = $sql->select('test', '*', $where);
+
+ # LDNOTE: this original test suite from NWIGER did no comparisons
+ # on @bind values, just checking if @bind is nonempty.
+ # So here we just fake a [1] bind value for the comparison.
+ is_same_sql_bind($stmt, [@bind ? 1 : 0], $_->{stmt}, [1]);
}
Modified: SQL-Abstract/1.x/trunk/t/01generate.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/01generate.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/01generate.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -3,10 +3,11 @@
use strict;
use warnings;
use Test::More;
+use Test::Warn;
+use Test::Exception;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
-plan tests => 60;
-
use SQL::Abstract;
my @tests = (
@@ -176,7 +177,7 @@
#21
{
func => 'update',
- args => ['test', {a => 1, b => ["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}],
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}],
stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )',
stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )',
bind => [qw(1 02/02/02 1 2)],
@@ -189,6 +190,13 @@
stmt_q => 'INSERT INTO `test`.`table` (`high_limit`, `low_limit`) VALUES (max(all_limits), ?)',
bind => ['4'],
},
+ {
+ func => 'insert',
+ args => ['test.table', [ \'max(all_limits)', 4 ] ],
+ stmt => 'INSERT INTO test.table VALUES (max(all_limits), ?)',
+ stmt_q => 'INSERT INTO `test`.`table` VALUES (max(all_limits), ?)',
+ bind => ['4'],
+ },
#23
{
func => 'insert',
@@ -245,10 +253,13 @@
tasty => { '!=', [qw(yes YES)] },
-nest => [ face => [ -or => {'=', 'mr.happy'}, {'=', undef} ] ] },
],
+# LDNOTE : modified the test below, same reasons as #14 in 00where.t
stmt => 'UPDATE taco_punches SET one = ?, three = ? WHERE ( ( ( ( ( face = ? ) OR ( face IS NULL ) ) ) )'
- . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )',
+# . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )',
+ . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) AND ( tasty != ? ) ) )',
stmt_q => 'UPDATE `taco_punches` SET `one` = ?, `three` = ? WHERE ( ( ( ( ( `face` = ? ) OR ( `face` IS NULL ) ) ) )'
- . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )',
+# . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )',
+ . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) AND ( `tasty` != ? ) ) )',
bind => [qw(2 4 mr.happy yes YES yes YES)],
},
#29
@@ -256,18 +267,29 @@
func => 'select',
args => ['jeff', '*', { name => {'like', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']},
-nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ],
- yob => {'<', 1976} ] ] } ],
- stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )'
- . ' AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )',
- stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )'
- . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? )',
+ yob => {'<', 1976} ] ] } ],
+# LDNOTE : original test below was WRONG with respect to the doc.
+# [-and, [cond1, cond2], cond3] should mean (cond1 OR cond2) AND cond3
+# instead of (cond1 AND cond2) OR cond3.
+# Probably a misconception because of '=>' notation
+# in [-and => [cond1, cond2], cond3].
+# Also some differences in parentheses, but without impact on semantics.
+# stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )'
+# . ' AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )',
+# stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )'
+# . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? )',
+ stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( age BETWEEN ? AND ? ) OR ( age != ? ) ) AND ( yob < ? ) ) )'
+ . ' AND ( name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? ) )',
+ stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( `age` BETWEEN ? AND ? ) OR ( `age` != ? ) ) AND ( `yob` < ? ) ) )'
+ . ' AND ( `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? ) )',
bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)]
},
#30
{
- # The "-maybe" should be ignored, as it sits at the top level (bug?)
func => 'update',
- args => ['fhole', {fpoles => 4}, [-maybe => {race => [-and => [qw(black white asian)]]},
+# LDNOTE : removed the "-maybe", because we no longer admit unknown ops
+# args => ['fhole', {fpoles => 4}, [-maybe => {race => [-and => [qw(black white asian)]]},
+ args => ['fhole', {fpoles => 4}, [ {race => [-and => [qw(black white asian)]]},
{-nest => {firsttime => [-or => {'=','yes'}, undef]}},
[ -and => {firstname => {-not_like => 'candace'}}, {lastname => {-in => [qw(jugs canyon towers)]}} ] ] ],
stmt => 'UPDATE fhole SET fpoles = ? WHERE ( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) )'
@@ -276,51 +298,286 @@
. ' OR ( ( ( ( `firsttime` = ? ) OR ( `firsttime` IS NULL ) ) ) ) OR ( ( ( `firstname` NOT LIKE ? ) ) AND ( `lastname` IN ( ?, ?, ? ) ) ) )',
bind => [qw(4 black white asian yes candace jugs canyon towers)]
},
+ #31
+ {
+ func => 'insert',
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ bind => [qw(1 02/02/02)],
+ },
+ #32
+ {
+ func => 'select',
+# LDNOTE: modified test below because we agreed with MST that literal SQL
+# should not automatically insert a '='; the user has to do it
+# args => ['test', '*', { a => \["to_date(?, 'MM/DD/YY')", '02/02/02']}],
+ args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}],
+ stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )},
+ stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )},
+ bind => ['02/02/02'],
+ },
+ #33
+ {
+ func => 'insert',
+ new => {array_datatypes => 1},
+ args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, ?)',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)',
+ bind => [1, [1, 1, 2, 3, 5, 8]],
+ },
+ #34
+ {
+ func => 'insert',
+ new => {bindtype => 'columns', array_datatypes => 1},
+ args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, ?)',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)',
+ bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]],
+ },
+ #35
+ {
+ func => 'update',
+ new => {array_datatypes => 1},
+ args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}],
+ stmt => 'UPDATE test SET a = ?, b = ?',
+ stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?',
+ bind => [1, [1, 1, 2, 3, 5, 8]],
+ },
+ #36
+ {
+ func => 'update',
+ new => {bindtype => 'columns', array_datatypes => 1},
+ args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}],
+ stmt => 'UPDATE test SET a = ?, b = ?',
+ stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?',
+ bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]],
+ },
+ #37
+ {
+ func => 'select',
+ args => ['test', '*', { a => {'>', \'1 + 1'}, b => 8 }],
+ stmt => 'SELECT * FROM test WHERE ( a > 1 + 1 AND b = ? )',
+ 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],
+ },
+ #39
+ { #TODO in SQLA >= 2.0 it will die instead (we kept this just because old SQLA passed it through)
+ func => 'insert',
+ args => ['test', {a => 1, b => 2, c => 3, d => 4, e => { answer => 42 }}],
+ stmt => 'INSERT INTO test (a, b, c, d, e) VALUES (?, ?, ?, ?, ?)',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`, `c`, `d`, `e`) VALUES (?, ?, ?, ?, ?)',
+ bind => [qw/1 2 3 4/, { answer => 42}],
+ warning_like => qr/HASH ref as bind value in insert is not supported/i,
+ },
+ #40
+ {
+ func => 'update',
+ args => ['test', {a => 1, b => \["42"]}, {a => {'between', [1,2]}}],
+ stmt => 'UPDATE test SET a = ?, b = 42 WHERE ( a BETWEEN ? AND ? )',
+ stmt_q => 'UPDATE `test` SET `a` = ?, `b` = 42 WHERE ( `a` BETWEEN ? AND ? )',
+ bind => [qw(1 1 2)],
+ },
+ #41
+ {
+ func => 'insert',
+ args => ['test', {a => 1, b => \["42"]}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, 42)',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, 42)',
+ bind => [qw(1)],
+ },
+ #42
+ {
+ func => 'select',
+ args => ['test', '*', { a => \["= 42"], b => 1}],
+ stmt => q{SELECT * FROM test WHERE ( a = 42 ) AND (b = ? )},
+ stmt_q => q{SELECT * FROM `test` WHERE ( `a` = 42 ) AND ( `b` = ? )},
+ bind => [qw(1)],
+ },
+ #43
+ {
+ func => 'select',
+ args => ['test', '*', { a => {'<' => \["42"]}, b => 8 }],
+ stmt => 'SELECT * FROM test WHERE ( a < 42 AND b = ? )',
+ stmt_q => 'SELECT * FROM `test` WHERE ( `a` < 42 AND `b` = ? )',
+ bind => [qw(8)],
+ },
+ #44
+ {
+ func => 'insert',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ bind => [[a => '1'], [dummy => '02/02/02']],
+ },
+ #45
+ {
+ func => 'update',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}, {a => {'between', [1,2]}}],
+ stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )',
+ stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )',
+ bind => [[a => '1'], [dummy => '02/02/02'], [a => '1'], [a => '2']],
+ },
+ #46
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}],
+ stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )},
+ stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )},
+ bind => [[dummy => '02/02/02']],
+ },
+ #47
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [dummy => '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 => [[dummy => '02/02/02'], [b => 8]],
+ },
+ #48
+ {
+ func => 'insert',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}],
+ exception_like => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/,
+ },
+ #49
+ {
+ func => 'update',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}],
+ exception_like => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/,
+ },
+ #49
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}],
+ exception_like => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/,
+ },
+ #50
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }],
+ exception_like => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/,
+ },
+ #51
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", [dummy => '02/02/02']]}, b => 8 }],
+ stmt => 'SELECT * FROM test WHERE ( a IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND b = ? )',
+ stmt_q => 'SELECT * FROM `test` WHERE ( `a` IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND `b` = ? )',
+ bind => [[dummy => '02/02/02'], [b => 8]],
+ },
+ #52
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", '02/02/02']}, b => 8 }],
+ exception_like => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/,
+ },
+ #53
+ {
+ func => 'insert',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}],
+ stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))',
+ bind => [[a => '1'], [{dummy => 1} => '02/02/02']],
+ },
+ #54
+ {
+ func => 'update',
+ new => {bindtype => 'columns'},
+ args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}, {a => {'between', [1,2]}}],
+ stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )',
+ stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )',
+ bind => [[a => '1'], [{dummy => 1} => '02/02/02'], [a => '1'], [a => '2']],
+ },
+ #55
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}],
+ stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )},
+ stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )},
+ bind => [[{dummy => 1} => '02/02/02']],
+ },
+ #56
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '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 => [[{dummy => 1} => '02/02/02'], [b => 8]],
+ },
);
-use Data::Dumper;
+plan tests => scalar(grep { !$_->{warning_like} } @tests) * 2
+ + scalar(grep { $_->{warning_like} } @tests) * 4;
+
for (@tests) {
- local $"=', ';
+ local $"=', ';
- my $new = $_->{new} || {};
- $new->{debug} = $ENV{DEBUG} || 0;
- my $sql = SQL::Abstract->new(%$new);
+ my $new = $_->{new} || {};
+ $new->{debug} = $ENV{DEBUG} || 0;
- #print "testing with args (@{$_->{args}}): ";
- my $func = $_->{func};
- my($stmt, @bind) = $sql->$func(@{$_->{args}});
- ok($stmt eq $_->{stmt} && equal(\@bind, $_->{bind})) or
- print "got\n",
- "[$stmt] [",Dumper(\@bind),"]\n",
- "instead of\n",
- "[$_->{stmt}] [",Dumper($_->{bind}),"]\n\n";
+ # test without quoting labels
+ {
+ my $sql = SQL::Abstract->new(%$new);
- # test with quoted labels
- my $sql_q = SQL::Abstract->new(%$new, quote_char => '`', name_sep => '.');
+ my $func = $_->{func};
+ my($stmt, @bind);
+ my $test = sub {
+ ($stmt, @bind) = $sql->$func(@{$_->{args}})
+ };
+ if ($_->{exception_like}) {
+ throws_ok { &$test } $_->{exception_like}, "throws the expected exception ($_->{exception_like})";
+ } else {
+ if ($_->{warning_like}) {
+ warning_like { &$test } $_->{warning_like}, "throws the expected warning ($_->{warning_like})";
+ } else {
+ &$test;
+ }
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+ }
+ }
- my $func_q = $_->{func};
- my($stmt_q, @bind_q) = $sql_q->$func_q(@{$_->{args}});
- ok($stmt_q eq $_->{stmt_q} && equal(\@bind_q, $_->{bind})) or
- print "got\n",
- "[$stmt_q] [",Dumper(\@bind_q),"]\n",
- "instead of\n",
- "[$_->{stmt_q}] [",Dumper($_->{bind}),"]\n\n";
-}
+ # test with quoted labels
+ {
+ my $sql_q = SQL::Abstract->new(%$new, quote_char => '`', name_sep => '.');
-sub equal {
- my ($a, $b) = @_;
- return 0 if @$a != @$b;
- for (my $i = 0; $i < $#{$a}; $i++) {
- next if (! defined($a->[$i])) && (! defined($b->[$i]));
- if (ref $a->[$i] && ref $b->[$i]) {
- return 0 if $a->[$i][0] ne $b->[$i][0]
- || $a->[$i][1] ne $b->[$i][1];
- } else {
- return 0 if $a->[$i] ne $b->[$i];
- }
+ my $func_q = $_->{func};
+ my($stmt_q, @bind_q);
+ my $test = sub {
+ ($stmt_q, @bind_q) = $sql_q->$func_q(@{$_->{args}})
+ };
+ if ($_->{exception_like}) {
+ throws_ok { &$test } $_->{exception_like}, "throws the expected exception ($_->{exception_like})";
+ } else {
+ if ($_->{warning_like}) {
+ warning_like { &$test } $_->{warning_like}, "throws the expected warning ($_->{warning_like})";
+ } else {
+ &$test;
}
- return 1;
+
+ is_same_sql_bind($stmt_q, \@bind_q, $_->{stmt_q}, $_->{bind});
+ }
+ }
}
-
-
Modified: SQL-Abstract/1.x/trunk/t/02where.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/02where.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/02where.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -4,14 +4,15 @@
use warnings;
use Test::More;
use Test::Exception;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
-plan tests => 27;
-
use SQL::Abstract;
# Make sure to test the examples, since having them break is somewhat
# embarrassing. :-(
+my $not_stringifiable = bless {}, 'SQLA::NotStringifiable';
+
my @handle_tests = (
{
where => {
@@ -26,6 +27,15 @@
},
{
+ where => [
+ status => 'completed',
+ user => 'nwiger',
+ ],
+ stmt => " WHERE ( status = ? OR user = ? )",
+ bind => [qw/completed nwiger/],
+ },
+
+ {
where => {
user => 'nwiger',
status => 'completed'
@@ -71,7 +81,9 @@
completion_date => { 'between', ['2002-10-01', '2003-02-06'] },
},
order => \'ticket, requestor',
- stmt => " WHERE ( completion_date BETWEEN ? AND ? AND status = ? ) ORDER BY ticket, requestor",
+#LDNOTE: modified parentheses
+# stmt => " WHERE ( completion_date BETWEEN ? AND ? AND status = ? ) ORDER BY ticket, requestor",
+ stmt => " WHERE ( ( completion_date BETWEEN ? AND ? ) AND status = ? ) ORDER BY ticket, requestor",
bind => [qw/2002-10-01 2003-02-06 completed/],
},
@@ -118,7 +130,9 @@
requestor => { 'like', undef },
},
order => \'requestor, ticket',
- stmt => " WHERE ( priority BETWEEN ? AND ? AND requestor IS NULL ) ORDER BY requestor, ticket",
+#LDNOTE: modified parentheses
+# stmt => " WHERE ( priority BETWEEN ? AND ? AND requestor IS NULL ) ORDER BY requestor, ticket",
+ stmt => " WHERE ( ( priority BETWEEN ? AND ? ) AND requestor IS NULL ) ORDER BY requestor, ticket",
bind => [qw/1 3/],
},
@@ -131,7 +145,9 @@
'>' => 10,
},
},
- stmt => " WHERE ( id = ? AND num <= ? AND num > ? )",
+# LDNOTE : modified test below, just parentheses differ
+# stmt => " WHERE ( id = ? AND num <= ? AND num > ? )",
+ stmt => " WHERE ( id = ? AND ( num <= ? AND num > ? ) )",
bind => [qw/1 20 10/],
},
@@ -143,7 +159,10 @@
wix => {'in' => [qw/zz yy/]},
wux => {'not_in' => [qw/30 40/]}
},
- stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND nix BETWEEN ? AND ? AND nox NOT BETWEEN ? AND ? AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )",
+# LDNOTE: modified parentheses for BETWEEN (trivial).
+# Also modified the logic of "not_like" (severe, same reasons as #14 in 00where.t)
+# stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND nix BETWEEN ? AND ? AND nox NOT BETWEEN ? AND ? AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )",
+ stmt => " WHERE ( ( foo NOT LIKE ? AND foo NOT LIKE ? AND foo NOT LIKE ? ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND ( nix BETWEEN ? AND ? ) AND ( nox NOT BETWEEN ? AND ? ) AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )",
bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'],
},
@@ -156,16 +175,52 @@
bind => [],
},
+
+ {
+ where => {
+ foo => \["IN (?, ?)", 22, 33],
+ bar => [-and => \["> ?", 44], \["< ?", 55] ],
+ },
+ stmt => " WHERE ( (bar > ? AND bar < ?) AND foo IN (?, ?) )",
+ bind => [44, 55, 22, 33],
+ },
+ {
+ where => { -and => [{}, { 'me.id' => '1'}] },
+ stmt => " WHERE ( ( me.id = ? ) )",
+ bind => [ 1 ],
+ },
+
+ {
+ where => { foo => $not_stringifiable, },
+ stmt => " WHERE ( foo = ? )",
+ bind => [ $not_stringifiable ],
+ },
+
+ {
+ where => \[ 'foo = ?','bar' ],
+ stmt => " WHERE (foo = ?)",
+ bind => [ "bar" ],
+ },
+
+ {
+ where => [ \[ 'foo = ?','bar' ] ],
+ stmt => " WHERE (foo = ?)",
+ bind => [ "bar" ],
+ },
);
+plan tests => ( @handle_tests * 2 ) + 1;
+
for my $case (@handle_tests) {
my $sql = SQL::Abstract->new;
- my($stmt, @bind) = $sql->where($case->{where}, $case->{order});
- is($stmt, $case->{stmt});
- is_deeply(\@bind, $case->{bind});
+ my($stmt, @bind);
+ lives_ok (sub {
+ ($stmt, @bind) = $sql->where($case->{where}, $case->{order});
+ is_same_sql_bind($stmt, \@bind, $case->{stmt}, $case->{bind});
+ });
}
dies_ok {
my $sql = SQL::Abstract->new;
$sql->where({ foo => { '>=' => [] }},);
-}
+};
Modified: SQL-Abstract/1.x/trunk/t/03values.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/03values.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/03values.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -4,13 +4,10 @@
use warnings;
use Test::More;
+use SQL::Abstract::Test import => [qw/is_same_sql_bind is_same_bind/];
-plan tests => 5;
-
use SQL::Abstract;
-my $sql = SQL::Abstract->new;
-
my @data = (
{
user => 'nwiger',
@@ -58,35 +55,67 @@
},
);
-# Note to self: I have no idea what this does anymore
-# It looks like a cool fucking segment of code though!
-# I just wish I remembered writing it... :-\
-my($sth, $stmt);
-my($laststmt, $numfields);
-for my $t (@data) {
- local $"=', ';
+plan tests => (@data * 5 + 2);
- $stmt = $sql->insert('yo_table', $t);
- my @val = $sql->values($t);
- $numfields ||= @val;
+# test insert() and values() for reentrancy
+my($insert_hash, $insert_array, $numfields);
+my $a_sql = SQL::Abstract->new;
+my $h_sql = SQL::Abstract->new;
- ok((! $laststmt || $stmt eq $laststmt) && @val == $numfields
- && equal(\@val, [map { $t->{$_} } sort keys %$t])) or
- print "got\n",
- "[$stmt] [@val]\n",
- "instead of\n",
- "[$t->{stmt}] [stuff]\n\n";
- $laststmt = $stmt;
+for my $record (@data) {
+
+ my $values = [ map { $record->{$_} } sort keys %$record ];
+
+ my ($h_stmt, @h_bind) = $h_sql->insert('h_table', $record);
+ my ($a_stmt, @a_bind) = $a_sql->insert('a_table', $values );
+
+ # init from first run, should not change afterwards
+ $insert_hash ||= $h_stmt;
+ $insert_array ||= $a_stmt;
+ $numfields ||= @$values;
+
+ is ( $a_stmt, $insert_array, 'Array-based insert statement unchanged' );
+ is ( $h_stmt, $insert_hash, 'Hash-based insert statement unchanged' );
+
+ is_deeply ( \@a_bind, \@h_bind, 'Bind values match after both insert() calls' );
+ is_deeply ( [$h_sql->values ($record)] , \@h_bind, 'values() output matches bind values after insert()' );
+
+ is ( scalar @h_bind, $numfields, 'Number of fields unchanged' );
}
-sub equal {
- my ($a, $b) = @_;
- return 0 if @$a != @$b;
- for (my $i = 0; $i < $#{$a}; $i++) {
- next if (! defined($a->[$i])) && (! defined($b->[$i]));
- return 0 if $a->[$i] ne $b->[$i];
- }
- return 1;
+# test values() with literal sql
+#
+# NOTE:
+# The example is deliberately complicated by the addition of a literal ? in xfunc
+# This is an intentional test making sure literal ? remains untouched.
+# It is rather impractical in the field, as the user will have to insert
+# a bindvalue for the literal position(s) in the correct offset of \@bind
+{
+ my $sql = SQL::Abstract->new;
+
+ my $data = {
+ event => 'rapture',
+ stuff => 'fluff',
+ time => \ 'now()',
+ xfunc => \ 'xfunc(?)',
+ yfunc => ['yfunc(?)', 'ystuff' ],
+ zfunc => \['zfunc(?)', 'zstuff' ],
+ zzlast => 'zzstuff',
+ };
+
+ my ($stmt, @bind) = $sql->insert ('table', $data);
+
+ is_same_sql_bind (
+ $stmt,
+ \@bind,
+ 'INSERT INTO table ( event, stuff, time, xfunc, yfunc, zfunc, zzlast) VALUES ( ?, ?, now(), xfunc (?), yfunc(?), zfunc(?), ? )',
+ [qw/rapture fluff ystuff zstuff zzstuff/], # event < stuff
+ );
+
+ is_same_bind (
+ [$sql->values ($data)],
+ [@bind],
+ 'values() output matches that of initial bind'
+ ) || diag "Corresponding SQL statement: $stmt";
}
-
Deleted: SQL-Abstract/1.x/trunk/t/04from.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/04from.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/04from.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -1,67 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-
-
-plan tests => 4;
-
-use SQL::Abstract;
-
-my $sa = new SQL::Abstract;
-
-my @j = (
- { child => 'person' },
- [ { father => 'person' }, { 'father.person_id' => 'child.father_id' }, ],
- [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-my $match = 'person child JOIN person father ON ( father.person_id = '
- . 'child.father_id ) JOIN person mother ON ( mother.person_id '
- . '= child.mother_id )'
- ;
-is( $sa->_recurse_from(@j), $match, 'join 1 ok' );
-
-my @j2 = (
- { mother => 'person' },
- [ [ { child => 'person' },
- [ { father => 'person' },
- { 'father.person_id' => 'child.father_id' }
- ]
- ],
- { 'mother.person_id' => 'child.mother_id' }
- ],
-);
-$match = 'person mother JOIN (person child JOIN person father ON ('
- . ' father.person_id = child.father_id )) ON ( mother.person_id = '
- . 'child.mother_id )'
- ;
-is( $sa->_recurse_from(@j2), $match, 'join 2 ok' );
-
-my @j3 = (
- { child => 'person' },
- [ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ],
- [ { mother => 'person', -join_type => 'inner' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-$match = 'person child INNER JOIN person father ON ( father.person_id = '
- . 'child.father_id ) INNER JOIN person mother ON ( mother.person_id '
- . '= child.mother_id )'
- ;
-
-is( $sa->_recurse_from(@j3), $match, 'join 3 (inner join) ok');
-
-my @j4 = (
- { mother => 'person' },
- [ [ { child => 'person', -join_type => 'left' },
- [ { father => 'person', -join_type => 'right' },
- { 'father.person_id' => 'child.father_id' }
- ]
- ],
- { 'mother.person_id' => 'child.mother_id' }
- ],
-);
-$match = 'person mother LEFT JOIN (person child RIGHT JOIN person father ON ('
- . ' father.person_id = child.father_id )) ON ( mother.person_id = '
- . 'child.mother_id )'
- ;
-is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok');
Deleted: SQL-Abstract/1.x/trunk/t/05quotes.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/05quotes.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/05quotes.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -1,188 +0,0 @@
-use strict;
-use warnings;
-
-use vars qw($TESTING);
-$TESTING = 1;
-use Test::More;
-
-# use a BEGIN block so we print our plan before SQL::Abstract is loaded
-BEGIN { plan tests => 7 }
-
-use SQL::Abstract;
-
-my $sql_maker = SQL::Abstract->new;
-
-$sql_maker->{quote_char} = '`';
-$sql_maker->{name_sep} = '.';
-
-my ($sql,) = $sql_maker->select(
- [
- {
- 'me' => 'cd'
- },
- [
- {
- 'artist' => 'artist',
- '-join_type' => ''
- },
- {
- 'artist.artistid' => 'me.artist'
- }
- ]
- ],
- [
- #{
- # 'count' => '*'
- #}
- \'COUNT( * )'
- ],
- {
- 'artist.name' => 'Caterwauler McCrae',
- 'me.year' => 2001
- },
- [],
- undef,
- undef
-);
-
-is($sql,
- q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/,
- 'got correct SQL for count query with quoting');
-
-
-($sql,) = $sql_maker->select(
- [
- {
- 'me' => 'cd'
- }
- ],
- [
- 'me.cdid',
- 'me.artist',
- 'me.title',
- 'me.year'
- ],
- undef,
- [
- { -desc => 'year' }
- ],
- undef,
- undef
-);
-
-
-
-
-is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/,
- 'quoted ORDER BY with DESC okay');
-
-
-($sql,) = $sql_maker->select(
- [
- {
- 'me' => 'cd'
- }
- ],
- [
- 'me.*'
- ],
- undef,
- [],
- undef,
- undef
-);
-
-is($sql, q/SELECT `me`.* FROM `cd` `me`/, 'select attr with me.* is right');
-
-($sql,) = $sql_maker->select(
- [
- {
- 'me' => 'cd'
- }
- ],
- [
- 'me.cdid',
- 'me.artist',
- 'me.title',
- 'me.year'
- ],
- undef,
- [
- \'year DESC'
- ],
- undef,
- undef
-);
-
-is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/,
- 'did not quote ORDER BY with scalarref');
-
-my %data = (
- name => 'Bill',
- order => 12
-);
-
-my @binds;
-
-($sql, at binds) = $sql_maker->update(
- 'group',
- {
- 'order' => '12',
- 'name' => 'Bill'
- }
-);
-
-is($sql,
- q/UPDATE `group` SET `name` = ?, `order` = ?/,
- 'quoted table names for UPDATE');
-
-$sql_maker->{quote_char} = [qw/[ ]/];
-
-($sql,) = $sql_maker->select(
- [
- {
- 'me' => 'cd'
- },
- [
- {
- 'artist' => 'artist',
- '-join_type' => ''
- },
- {
- 'artist.artistid' => 'me.artist'
- }
- ]
- ],
- [
- #{
- # 'count' => '*'
- #}
- \'COUNT( * )'
- ],
- {
- 'artist.name' => 'Caterwauler McCrae',
- 'me.year' => 2001
- },
- [],
- undef,
- undef
-);
-
-is($sql,
- q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/,
- 'got correct SQL for count query with bracket quoting');
-
-
-($sql, at binds) = $sql_maker->update(
- 'group',
- {
- 'order' => '12',
- 'name' => 'Bill'
- }
-);
-
-is($sql,
- q/UPDATE [group] SET [name] = ?, [order] = ?/,
- 'bracket quoted table names for UPDATE');
Modified: SQL-Abstract/1.x/trunk/t/06order_by.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/06order_by.t 2009-03-19 17:05:00 UTC (rev 5772)
+++ SQL-Abstract/1.x/trunk/t/06order_by.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -6,6 +6,7 @@
use SQL::Abstract;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
my @cases =
(
{
@@ -18,11 +19,21 @@
expects => ' ORDER BY colA',
expects_quoted => ' ORDER BY `colA`',
},
+ { # it may look odd, but this is the desired behaviour (mst)
+ given => 'colA DESC',
+ expects => ' ORDER BY colA DESC',
+ expects_quoted => ' ORDER BY `colA DESC`',
+ },
{
given => [qw/colA colB/],
expects => ' ORDER BY colA, colB',
expects_quoted => ' ORDER BY `colA`, `colB`',
},
+ { # it may look odd, but this is the desired behaviour (mst)
+ given => ['colA ASC', 'colB DESC'],
+ expects => ' ORDER BY colA ASC, colB DESC',
+ expects_quoted => ' ORDER BY `colA ASC`, `colB DESC`',
+ },
{
given => {-asc => 'colA'},
expects => ' ORDER BY colA ASC',
@@ -43,13 +54,19 @@
expects => ' ORDER BY colA, colB DESC',
expects_quoted => ' ORDER BY `colA`, `colB` DESC',
},
+ {
+ given => undef,
+ expects => '',
+ expects_quoted => '',
+ },
);
+
+plan tests => (scalar(@cases) * 2);
+
my $sql = SQL::Abstract->new;
my $sqlq = SQL::Abstract->new({quote_char => '`'});
-plan tests => (scalar(@cases) * 2);
-
for my $case( @cases){
is($sql->_order_by($case->{given}), $case->{expects});
is($sqlq->_order_by($case->{given}), $case->{expects_quoted});
Added: SQL-Abstract/1.x/trunk/t/07subqueries.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/07subqueries.t (rev 0)
+++ SQL-Abstract/1.x/trunk/t/07subqueries.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -0,0 +1,105 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+use SQL::Abstract;
+
+my $sql = SQL::Abstract->new;
+
+my (@tests, $sub_stmt, @sub_bind, $where);
+
+#1
+($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+$where = {
+ foo => 1234,
+ bar => \["IN ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+#2
+($sub_stmt, @sub_bind)
+ = $sql->select("t1", "c1", {c2 => {"<" => 100},
+ c3 => {-like => "foo%"}});
+$where = {
+ foo => 1234,
+ bar => \["> ALL ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+#3
+($sub_stmt, @sub_bind)
+ = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
+$where = {
+ foo => 1234,
+ -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )",
+ bind => [1, 1234],
+};
+
+#4
+$where = {
+ -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )",
+ bind => ["apples"],
+};
+
+
+#5
+($sub_stmt, @sub_bind)
+ = $sql->where({age => [{"<" => 10}, {">" => 20}]});
+$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
+$where = {
+ lname => {-like => '%son%'},
+ -nest => \["NOT ( $sub_stmt )" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )",
+ bind => [10, 20, '%son%'],
+};
+
+#6
+($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+$where = {
+ foo => 1234,
+ bar => { -in => \[$sub_stmt => @sub_bind] },
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+
+plan tests => scalar(@tests);
+
+for (@tests) {
+
+ my($stmt, @bind) = $sql->where($_->{where}, $_->{order});
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Added: SQL-Abstract/1.x/trunk/t/08special_ops.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/08special_ops.t (rev 0)
+++ SQL-Abstract/1.x/trunk/t/08special_ops.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -0,0 +1,69 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+use SQL::Abstract;
+
+my $sqlmaker = SQL::Abstract->new(special_ops => [
+
+ # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
+ {regex => qr/^match$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg = [$arg] if not ref $arg;
+ my $label = $self->_quote($field);
+ my ($placeholder) = $self->_convert('?');
+ my $placeholders = join ", ", (($placeholder) x @$arg);
+ my $sql = $self->_sqlcase('match') . " ($label) "
+ . $self->_sqlcase('against') . " ($placeholders) ";
+ my @bind = $self->_bindtype($field, @$arg);
+ return ($sql, @bind);
+ }
+ },
+
+ # special op for Basis+ NATIVE
+ {regex => qr/^native$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg =~ s/'/''/g;
+ my $sql = "NATIVE (' $field $arg ')";
+ return ($sql);
+ }
+ },
+
+]);
+
+my @tests = (
+
+ #1
+ { where => {foo => {-match => 'foo'},
+ bar => {-match => [qw/foo bar/]}},
+ stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )",
+ bind => [qw/foo bar foo/],
+ },
+
+ #2
+ { where => {foo => {-native => "PH IS 'bar'"}},
+ stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )",
+ bind => [],
+ },
+
+);
+
+
+plan tests => scalar(@tests);
+
+for (@tests) {
+
+ my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order});
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Added: SQL-Abstract/1.x/trunk/t/09refkind.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/09refkind.t (rev 0)
+++ SQL-Abstract/1.x/trunk/t/09refkind.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use SQL::Abstract;
+
+plan tests => 13;
+
+my $obj = bless {}, "Foo::Bar";
+
+is(SQL::Abstract->_refkind(undef), 'UNDEF', 'UNDEF');
+
+is(SQL::Abstract->_refkind({}), 'HASHREF', 'HASHREF');
+is(SQL::Abstract->_refkind([]), 'ARRAYREF', 'ARRAYREF');
+
+is(SQL::Abstract->_refkind(\{}), 'HASHREFREF', 'HASHREFREF');
+is(SQL::Abstract->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF');
+
+is(SQL::Abstract->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF');
+is(SQL::Abstract->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF');
+
+is(SQL::Abstract->_refkind("foo"), 'SCALAR', 'SCALAR');
+is(SQL::Abstract->_refkind(\"foo"), 'SCALARREF', 'SCALARREF');
+is(SQL::Abstract->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF');
+
+# objects are treated like scalars
+is(SQL::Abstract->_refkind($obj), 'SCALAR', 'SCALAR');
+is(SQL::Abstract->_refkind(\$obj), 'SCALARREF', 'SCALARREF');
+is(SQL::Abstract->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF');
+
Added: SQL-Abstract/1.x/trunk/t/10test.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/10test.t (rev 0)
+++ SQL-Abstract/1.x/trunk/t/10test.t 2009-03-19 18:58:41 UTC (rev 5773)
@@ -0,0 +1,724 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use List::Util qw(sum);
+
+use Test::More;
+
+
+my @sql_tests = (
+ # WHERE condition - equal
+ {
+ equal => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1/,
+ q/SELECT foo FROM bar WHERE a=1/,
+ q/SELECT foo FROM bar WHERE (a = 1)/,
+ q/SELECT foo FROM bar WHERE (a=1)/,
+ q/SELECT foo FROM bar WHERE ( a = 1 )/,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ a = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ (a = 1)
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ ( a = 1 )
+ /,
+ q/SELECT foo FROM bar WHERE ((a = 1))/,
+ q/SELECT foo FROM bar WHERE ( (a = 1) )/,
+ q/SELECT foo FROM bar WHERE ( ( a = 1 ) )/,
+ ]
+ },
+ {
+ equal => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/,
+ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1)/,
+ q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 1))/,
+ q/SELECT foo FROM bar WHERE (a = 1 AND b = 1)/,
+ q/SELECT foo FROM bar WHERE ((a = 1 AND b = 1))/,
+ q/SELECT foo FROM bar WHERE (((a = 1) AND (b = 1)))/,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ a = 1
+ AND
+ b = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ (a = 1
+ AND
+ b = 1)
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ (a = 1)
+ AND
+ (b = 1)
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ WHERE
+ ((a = 1)
+ AND
+ (b = 1))
+ /,
+ ]
+ },
+
+ # WHERE condition - different
+ {
+ equal => 0,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1/,
+ q/SELECT quux FROM bar WHERE a = 1/,
+ q/SELECT foo FROM quux WHERE a = 1/,
+ q/FOOBAR foo FROM bar WHERE a = 1/,
+
+ q/SELECT foo FROM bar WHERE a = 2/,
+ q/SELECT foo FROM bar WHERE a < 1/,
+ q/SELECT foo FROM bar WHERE b = 1/,
+ q/SELECT foo FROM bar WHERE (c = 1)/,
+ q/SELECT foo FROM bar WHERE (d = 1)/,
+
+ q/SELECT foo FROM bar WHERE a = 1 AND quux/,
+ q/SELECT foo FROM bar WHERE a = 1 GROUP BY foo/,
+ q/SELECT foo FROM bar WHERE a = 1 ORDER BY foo/,
+ q/SELECT foo FROM bar WHERE a = 1 LIMIT 1/,
+ q/SELECT foo FROM bar WHERE a = 1 OFFSET 1/,
+ q/SELECT foo FROM bar JOIN quux WHERE a = 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1/,
+ ]
+ },
+ {
+ equal => 0,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/,
+ q/SELECT quux FROM bar WHERE a = 1 AND b = 1/,
+ q/SELECT foo FROM quux WHERE a = 1 AND b = 1/,
+ q/FOOBAR foo FROM bar WHERE a = 1 AND b = 1/,
+
+ q/SELECT foo FROM bar WHERE a = 2 AND b = 1/,
+ q/SELECT foo FROM bar WHERE a = 3 AND (b = 1)/,
+ q/SELECT foo FROM bar WHERE (a = 4) AND b = 1/,
+ q/SELECT foo FROM bar WHERE (a = 5) AND (b = 1)/,
+ q/SELECT foo FROM bar WHERE ((a = 6) AND (b = 1))/,
+ q/SELECT foo FROM bar WHERE ((a = 7) AND (b = 1))/,
+
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 2/,
+ q/SELECT foo FROM bar WHERE a = 1 AND (b = 3)/,
+ q/SELECT foo FROM bar WHERE (a = 1) AND b = 4/,
+ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 5)/,
+ q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 6))/,
+ q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 7))/,
+
+ q/SELECT foo FROM bar WHERE a < 1 AND b = 1/,
+ q/SELECT foo FROM bar WHERE b = 1 AND b = 1/,
+ q/SELECT foo FROM bar WHERE (c = 1) AND b = 1/,
+ q/SELECT foo FROM bar WHERE (d = 1) AND b = 1/,
+
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND quux/,
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 GROUP BY foo/,
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 ORDER BY foo/,
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 LIMIT 1/,
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 OFFSET 1/,
+ q/SELECT foo FROM bar JOIN quux WHERE a = 1 AND b = 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1 AND b = 1/,
+ ]
+ },
+
+ # JOIN condition - equal
+ {
+ equal => 1,
+ statements => [
+ q/SELECT foo FROM bar JOIN baz ON a = 1 WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON a=1 WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON (a = 1) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON (a=1) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON ( a = 1 ) WHERE x = 1/,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ a = 1
+ WHERE
+ x = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ (a = 1)
+ WHERE
+ x = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ ( a = 1 )
+ WHERE
+ x = 1
+ /,
+ q/SELECT foo FROM bar JOIN baz ON ((a = 1)) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON ( (a = 1) ) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON ( ( a = 1 ) ) WHERE x = 1/,
+ ]
+ },
+ {
+ equal => 1,
+ statements => [
+ q/SELECT foo FROM bar JOIN baz ON a = 1 AND b = 1 WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON (a = 1) AND (b = 1) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON ((a = 1) AND (b = 1)) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON (a = 1 AND b = 1) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON ((a = 1 AND b = 1)) WHERE x = 1/,
+ q/SELECT foo FROM bar JOIN baz ON (((a = 1) AND (b = 1))) WHERE x = 1/,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ a = 1
+ AND
+ b = 1
+ WHERE
+ x = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ (a = 1
+ AND
+ b = 1)
+ WHERE
+ x = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ (a = 1)
+ AND
+ (b = 1)
+ WHERE
+ x = 1
+ /,
+ q/
+ SELECT
+ foo
+ FROM
+ bar
+ JOIN
+ baz
+ ON
+ ((a = 1)
+ AND
+ (b = 1))
+ WHERE
+ x = 1
+ /,
+ ]
+ },
+
+ # JOIN condition - different
+ {
+ equal => 0,
+ statements => [
+ q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE quuux/,
+ q/SELECT quux FROM bar JOIN quux ON a = 1 WHERE quuux/,
+ q/SELECT foo FROM quux JOIN quux ON a = 1 WHERE quuux/,
+ q/FOOBAR foo FROM bar JOIN quux ON a = 1 WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a = 2 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a < 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (c = 1) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (d = 1) WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 GROUP BY foo/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 ORDER BY foo/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 LIMIT 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 OFFSET 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1/,
+ ]
+ },
+ {
+ equal => 0,
+ statements => [
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/,
+ q/SELECT quux FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM quux JOIN quux ON a = 1 AND b = 1 WHERE quuux/,
+ q/FOOBAR foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a = 2 AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a = 3 AND (b = 1) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (a = 4) AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (a = 5) AND (b = 1) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON ((a = 6) AND (b = 1)) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON ((a = 7) AND (b = 1)) WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 2 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND (b = 3) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (a = 1) AND b = 4 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (a = 1) AND (b = 5) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 6)) WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 7)) WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a < 1 AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON b = 1 AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (c = 1) AND b = 1 WHERE quuux/,
+ q/SELECT foo FROM bar JOIN quux ON (d = 1) AND b = 1 WHERE quuux/,
+
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 AND quuux/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 GROUP BY foo/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 ORDER BY foo/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 LIMIT 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 OFFSET 1/,
+ q/SELECT foo FROM bar JOIN quux JOIN quuux ON a = 1 AND b = 1/,
+ q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1 AND b = 1/,
+ ]
+ },
+
+ # DISTINCT ON (...) not confused with JOIN ON (...)
+ {
+ equal => 1,
+ statements => [
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a = 1/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a=1/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a = 1)/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a=1)/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( a = 1 )/,
+ q/
+ SELECT DISTINCT ON (foo, quux)
+ foo,
+ quux
+ FROM
+ bar
+ WHERE
+ a = 1
+ /,
+ q/
+ SELECT DISTINCT ON (foo, quux)
+ foo,
+ quux
+ FROM
+ bar
+ WHERE
+ (a = 1)
+ /,
+ q/
+ SELECT DISTINCT ON (foo, quux)
+ foo,
+ quux
+ FROM
+ bar
+ WHERE
+ ( a = 1 )
+ /,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ((a = 1))/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( (a = 1) )/,
+ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( ( a = 1 ) )/,
+ ]
+ },
+
+ # subselects - equal
+ {
+ equal => 1,
+ statements => [
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 1)/,
+ ]
+ },
+ {
+ equal => 1,
+ statements => [
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE a = 1/,
+
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE (a = 1)/,
+ ]
+ },
+
+ # subselects - different
+ {
+ equal => 0,
+ statements => [
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 2/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 3)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 4/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 5)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 2) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 3) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 4)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 5)) AS foo WHERE (a = 1)/,
+ ]
+ },
+ {
+ equal => 0,
+ statements => [
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 1/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 1/,
+
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 1)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 1)/,
+
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 2/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 2/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 2/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 2/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 2/,
+
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 2)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 2)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 2)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 2)/,
+ q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 2)/,
+ ]
+ },
+);
+
+my @bind_tests = (
+ # scalar - equal
+ {
+ equal => 1,
+ bindvals => [
+ undef,
+ undef,
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 'foo',
+ 'foo',
+ ]
+ },
+ {
+ equal => 1,
+ bindvals => [
+ 42,
+ 42,
+ '42',
+ ]
+ },
+
+ # 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
+ ) +
+ 3;
+
+use_ok('SQL::Abstract::Test', import => [qw(
+ eq_sql_bind eq_sql eq_bind is_same_sql_bind
+)]);
+
+for my $test (@sql_tests) {
+ my $statements = $test->{statements};
+ while (@$statements) {
+ my $sql1 = shift @$statements;
+ foreach my $sql2 (@$statements) {
+ my $equal = eq_sql($sql1, $sql2);
+ if ($test->{equal}) {
+ ok($equal, "equal SQL expressions considered equal");
+ } else {
+ ok(!$equal, "different SQL expressions considered not equal");
+ }
+
+ if ($equal ^ $test->{equal}) {
+ diag("sql1: $sql1");
+ diag("sql2: $sql2");
+ }
+ }
+ }
+}
+
+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));
+ }
+ }
+ }
+}
+
+ok(eq_sql_bind(
+ "SELECT * FROM foo WHERE id = ?", [42],
+ "SELECT * FROM foo WHERE (id = ?)", [42],
+ ),
+ "eq_sql_bind considers equal SQL expressions and bind values equal"
+);
+
+
+ok(!eq_sql_bind(
+ "SELECT * FROM foo WHERE id = ?", [42],
+ "SELECT * FROM foo WHERE (id = ?)", [0],
+ ),
+ "eq_sql_bind considers equal SQL expressions and different bind values different"
+);
+
+ok(!eq_sql_bind(
+ "SELECT * FROM foo WHERE id = ?", [42],
+ "SELECT * FROM bar WHERE (id = ?)", [42],
+ ),
+ "eq_sql_bind considers different SQL expressions and equal bind values different"
+);
More information about the Bast-commits
mailing list