_aliases => { self => $from, foreign => $to },
_action => 'join',
};
- my $join = $from_class->_cond_resolve($rel_obj->{cond}, $attrs);
+ my $join = $from_class->storage->sql_maker->where(
+ $from_class->resolve_condition($rel_obj->{cond}, $attrs) );
+ $join =~ s/^\s*WHERE//i;
return $join;
}
my $h = $class->_transform_sql_handlers->{$key};
$sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
}
+ #warn $sql;
return sprintf($sql, @args);
}
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/
- Relationship
InflateColumn
- SQL::Abstract
+ Relationship
PK
Row
Table
my %join = (%$attrs, _action => 'join',
_aliases => { 'self' => 'me', 'foreign' => $rel },
_classes => { 'me' => $class, $rel => $f_class });
- eval { $class->_cond_resolve($cond, \%join) };
+ eval { $class->resolve_condition($cond, \%join) };
if ($@) { # If the resolve failed, back out and re-throw the error
delete $rels{$rel}; #
1;
}
+sub resolve_condition {
+ my ($self, $cond, $attrs) = @_;
+ if (ref $cond eq 'HASH') {
+ my %ret;
+ foreach my $key (keys %$cond) {
+ my $val = $cond->{$key};
+ if (ref $val) {
+ $self->throw("Can't handle this yet :(");
+ } else {
+ $ret{$self->_cond_key($attrs => $key)}
+ = $self->_cond_value($attrs => $key => $val);
+ }
+ }
+ return \%ret;
+ } else {
+ $self->throw("Can't handle this yet :(");
+ }
+}
+
sub _cond_key {
my ($self, $attrs, $key) = @_;
my $action = $attrs->{_action} || '';
unless ($self->_columns->{$value}) {
$self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
}
- push(@{$attrs->{bind}}, $self->get_column($value));
- return '?';
+ return $self->get_column($value);
} elsif ($action eq 'join') {
my ($type, $field) = split(/\./, $value);
if (my $alias = $attrs->{_aliases}{$type}) {
my $class = $attrs->{_classes}{$alias};
$self->throw("Unknown column $field on $class as $alias")
unless exists $class->_columns->{$field};
- return join('.', $alias, $field);
+ my $ret = join('.', $alias, $field);
+ # return { '=' => \$ret }; # SQL::Abstract doesn't handle this yet :(
+ $ret = " = ${ret}";
+ return \$ret;
} else {
$self->throw( "Unable to resolve type ${type}: only have aliases for ".
join(', ', keys %{$attrs->{_aliases} || {}}) );
$attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
# to merge into the AST really?
- my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
- $query = ($query ? { '-and' => [ \$cond, $query ] } : \$cond);
+ my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
+ $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
#use Data::Dumper; warn Dumper($query);
- #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
+ #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
delete $attrs->{_action};
return $self->resolve_class($rel_obj->{class}
)->$meth($query, $attrs);
$self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
unless ref $rel_obj->{cond} eq 'HASH';
$attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
- my %fields = %$values;
- while (my ($k, $v) = each %{$rel_obj->{cond}}) {
- $self->_cond_value($attrs, $k => $v);
- $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
- }
+
+ my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
+ $fields{$_} = $values->{$_} for keys %$values;
+
return $self->resolve_class($rel_obj->{class})->new(\%fields);
}
+++ /dev/null
-package DBIx::Class::SQL;
-
-use strict;
-use warnings;
-
-use base qw/Class::Data::Inheritable/;
-
-use constant COLS => 0;
-use constant FROM => 1;
-use constant COND => 2;
-
-=head1 NAME
-
-DBIx::Class::SQL - SQL Specific methods for DBIx::Class
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This class contains methods that generates SQL queries for
-the rest of the L<DBIx::Class> hiarchy. It's also responsible
-for executing these.
-
-=cut
-
-__PACKAGE__->mk_classdata('_sql_statements',
- {
- 'select' =>
- sub { "SELECT ".join(', ', @{$_[COLS]})." FROM $_[FROM] WHERE $_[COND]"; },
- 'update' =>
- sub { "UPDATE $_[FROM] SET $_[COLS] WHERE $_[COND]"; },
- 'insert' =>
- sub { "INSERT INTO $_[FROM] (".join(', ', @{$_[COLS]}).") VALUES (".
- join(', ', map { '?' } @{$_[COLS]}).")"; },
- 'delete' =>
- sub { "DELETE FROM $_[FROM] WHERE $_[COND]"; },
- } );
-
-sub create_sql {
- my ($class, $name, $cols, $from, $cond) = @_;
- my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond);
- #warn $sql;
- return $sql;
-}
-
-*_get_sql = \&create_sql;
-
-1;
-
-=head1 AUTHORS
-
-Matt S. Trout <perl-stuff@trout.me.uk>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package DBIx::Class::SQL::Abstract;
-
-use strict;
-use warnings;
-
-# Many thanks to SQL::Abstract, from which I stole most of this
-
-sub _debug { }
-
-sub _cond_resolve {
- my ($self, $cond, $attrs, $join) = @_;
- $cond = $self->_anoncopy($cond); # prevent destroying original
- my $ref = ref $cond || '';
- $join ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND');
- my $cmp = uc($attrs->{cmp}) || '=';
-
- # For assembling SQL fields and values
- my(@sqlf) = ();
-
- # 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 @$cond) {
-
- # 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 ||= '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") if $subjoin;
- $el = {$el => shift(@$cond)};
- }
- my @ret = $self->_cond_resolve($el, $attrs, $subjoin);
- push @sqlf, shift @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 %$cond) {
- my $v = $cond->{$k};
- if ($k =~ /^-(.*)/) {
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = $self->_modlogic($attrs, uc($1));
- $self->_debug("OP(-$1) means special logic ($subjoin), recursing...");
- my @ret = $self->_cond_resolve($v, $attrs, $subjoin);
- push @sqlf, shift @ret;
- } elsif (! defined($v)) {
- # undef = null
- $self->_debug("UNDEF($k) means IS NULL");
- push @sqlf, $self->_cond_key($attrs => $k) . ' IS NULL'
- } elsif (ref $v eq 'ARRAY') {
- # multiple elements: multiple options
- # warnings... $self->_debug("ARRAY($k) means multiple elements: [ @$v ]");
-
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = 'OR';
- if ($v->[0] =~ /^-(.*)/) {
- $subjoin = $self->_modlogic($attrs, uc($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->_cond_resolve([map { {$k => $_} } @$v], $attrs, $subjoin);
-
- # push results into our structure
- push @sqlf, shift @ret;
- } elsif (ref $v eq 'HASH') {
- # modified operator { '!=', 'completed' }
- for my $f (sort keys %$v) {
- my $x = $v->{$f};
- $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 $mod = $1 ? $1 . $2 : $2; # avoid uninitialized value warnings
- my $u = $self->_modlogic($attrs, uc($mod));
- $self->_debug("HASH($f => $x) uses special operator: [ $u ]");
- if ($u =~ /BETWEEN/) {
- # SQL sucks
- $self->throw( "BETWEEN must have exactly two arguments" ) unless @$x == 2;
- push @sqlf, join ' ',
- $self->_cond_key($attrs => $k), $u,
- $self->_cond_value($attrs => $k => $x->[0]),
- 'AND',
- $self->_cond_value($attrs => $k => $x->[1]);
- } else {
- push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(',
- join(', ',
- map { $self->_cond_value($attrs, $k, $_) } @$x),
- ')';
- }
- } else {
- # multiple elements: multiple options
- $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
-
- # map into an array of hashrefs and recurse
- my @ret = $self->_cond_resolve([map { {$k => {$f, $_}} } @$x], $attrs);
-
- # push results into our structure
- push @sqlf, shift @ret;
- }
- } elsif (! defined($x)) {
- # undef = NOT null
- my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : '';
- push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL";
- } else {
- # regular ol' value
- $f =~ s/^-//; # strip leading -like =>
- $f =~ s/_/ /; # _ => " "
- push @sqlf, join ' ', $self->_cond_key($attrs => $k), uc($f),
- $self->_cond_value($attrs => $k => $x);
- }
- }
- } elsif (ref $v eq 'SCALAR') {
- # literal SQL
- $self->_debug("SCALAR($k) means literal SQL: $$v");
- push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v;
- } else {
- # standard key => val
- $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v");
- push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp,
- $self->_cond_value($attrs => $k => $v);
- }
- }
- }
- elsif ($ref eq 'SCALAR') {
- # literal sql
- $self->_debug("SCALAR(*top) means literal SQL: $$cond");
- push @sqlf, $$cond;
- }
- elsif (defined $cond) {
- # literal sql
- $self->_debug("NOREF(*top) means literal SQL: $cond");
- push @sqlf, $cond;
- }
-
- # assemble and return sql
- my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '1 = 1';
- return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql;
-}
-
-sub _cond_key {
- my ($self, $attrs, $key) = @_;
- return $key;
-}
-
-sub _cond_value {
- my ($self, $attrs, $key, $value) = @_;
- push(@{$attrs->{bind}}, $value);
- return '?';
-}
-
-# Anon copies of arrays/hashes
-sub _anoncopy {
- my ($self, $orig) = @_;
- return (ref $orig eq 'HASH' ) ? { %$orig }
- : (ref $orig eq 'ARRAY') ? [ @$orig ]
- : $orig; # rest passthru ok
-}
-
-sub _modlogic {
- my ($self, $attrs, $sym) = @_;
- $sym ||= $attrs->{logic};
- $sym =~ tr/_/ /;
- $sym = $attrs->{logic} if $sym eq 'nest';
- return uc($sym); # override join
-}
-
-1;
-
-=head1 NAME
-
-DBIx::Class::SQL::Abstract - SQL::Abstract customized for DBIC.
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This is a customized version of L<SQL::Abstract> for use in
-generating L<DBIx::Searchbuilder> searches.
-
-=cut
-
-=head1 AUTHORS
-
-Matt S. Trout <perl-stuff@trout.me.uk>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/SQL SQL::Abstract Exception AccessorGroup/);
+__PACKAGE__->load_components(qw/Exception AccessorGroup/);
__PACKAGE__->mk_group_accessors('simple' =>
qw/connect_info _dbh sql_maker debug cursor/);
unshift(@bind, @$extra_bind) if $extra_bind;
warn "$sql: @bind" if $self->debug;
my $sth = $self->sth($sql);
- @bind = map { ref $_ ? ''.$_ : $_ } @bind;
- my $rv = $sth->execute(@bind); # stringify args
+ @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+ my $rv = $sth->execute(@bind);
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
+++ /dev/null
-use Test::More;\r
-\r
-plan tests => 56;\r
-\r
-use DBIx::Class::SQL::Abstract;\r
-\r
-# Make sure to test the examples, since having them break is somewhat\r
-# embarrassing. :-(\r
-\r
-my @handle_tests = (\r
- {\r
- where => {\r
- requestor => 'inna',\r
- worker => ['nwiger', 'rcwe', 'sfz'],\r
- status => { '!=', 'completed' }\r
- },\r
- stmt => "( requestor = ? AND status != ? AND ( ( worker = ? ) OR"\r
- . " ( worker = ? ) OR ( worker = ? ) ) )",\r
- bind => [qw/inna completed nwiger rcwe sfz/],\r
- },\r
-\r
- {\r
- where => {\r
- user => 'nwiger',\r
- status => 'completed'\r
- },\r
- stmt => "( status = ? AND user = ? )",\r
- bind => [qw/completed nwiger/],\r
- },\r
-\r
- {\r
- where => {\r
- user => 'nwiger',\r
- status => { '!=', 'completed' }\r
- },\r
- stmt => "( status != ? AND user = ? )",\r
- bind => [qw/completed nwiger/],\r
- },\r
-\r
- {\r
- where => {\r
- status => 'completed',\r
- reportid => { 'in', [567, 2335, 2] }\r
- },\r
- stmt => "( reportid IN ( ?, ?, ? ) AND status = ? )",\r
- bind => [qw/567 2335 2 completed/],\r
- },\r
-\r
- {\r
- where => {\r
- status => 'completed',\r
- reportid => { 'not in', [567, 2335, 2] }\r
- },\r
- stmt => "( reportid NOT IN ( ?, ?, ? ) AND status = ? )",\r
- bind => [qw/567 2335 2 completed/],\r
- },\r
-\r
- {\r
- where => {\r
- status => 'completed',\r
- completion_date => { 'between', ['2002-10-01', '2003-02-06'] },\r
- },\r
- stmt => "( completion_date BETWEEN ? AND ? AND status = ? )",\r
- bind => [qw/2002-10-01 2003-02-06 completed/],\r
- },\r
-\r
- {\r
- where => [\r
- {\r
- user => 'nwiger',\r
- status => { 'in', ['pending', 'dispatched'] },\r
- },\r
- {\r
- user => 'robot',\r
- status => 'unassigned',\r
- },\r
- ],\r
- stmt => "( ( status IN ( ?, ? ) AND user = ? ) OR ( status = ? AND user = ? ) )",\r
- bind => [qw/pending dispatched nwiger unassigned robot/],\r
- },\r
-\r
- {\r
- where => { \r
- priority => [ {'>', 3}, {'<', 1} ],\r
- requestor => \'is not null',\r
- },\r
- stmt => "( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor is not null )",\r
- bind => [qw/3 1/],\r
- },\r
-\r
- {\r
- where => { \r
- priority => [ {'>', 3}, {'<', 1} ],\r
- requestor => { '!=', undef }, \r
- },\r
- stmt => "( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor IS NOT NULL )",\r
- bind => [qw/3 1/],\r
- },\r
-\r
- {\r
- where => { \r
- priority => { 'between', [1, 3] },\r
- requestor => { 'like', undef }, \r
- },\r
- stmt => "( priority BETWEEN ? AND ? AND requestor IS NULL )",\r
- bind => [qw/1 3/],\r
- },\r
-\r
-\r
- {\r
- where => { \r
- id => 1,\r
- num => {\r
- '<=' => 20,\r
- '>' => 10,\r
- },\r
- },\r
- stmt => "( id = ? AND num <= ? AND num > ? )",\r
- bind => [qw/1 20 10/],\r
- },\r
-\r
- {\r
- where => { foo => {-not_like => [7,8,9]},\r
- fum => {'like' => [qw/a b/]},\r
- nix => {'between' => [100,200] },\r
- nox => {'not between' => [150,160] },\r
- wix => {'in' => [qw/zz yy/]},\r
- wux => {'not_in' => [qw/30 40/]}\r
- },\r
- stmt => "( ( ( 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 ( ?, ? ) )",\r
- bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'],\r
- },\r
- \r
- # a couple of the more complex tests from S::A 01generate.t that test -nest, etc.\r
- {\r
- where => { name => {'like', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']},\r
- -nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ],\r
- yob => {'<', 1976} ] ] },\r
- stmt => "( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) ) AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )",\r
- bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)],\r
- },\r
- \r
- {\r
- where => [-maybe => {race => [-and => [qw(black white asian)]]},\r
- {-nest => {firsttime => [-or => {'=','yes'}, undef]}},\r
- [ -and => {firstname => {-not_like => 'candace'}}, {lastname => {-in => [qw(jugs canyon towers)]}} ] ],\r
- stmt => "( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) ) OR ( ( ( ( firsttime = ? ) OR ( firsttime IS NULL ) ) ) ) OR ( ( ( firstname NOT LIKE ? ) ) AND ( lastname IN ( ?, ?, ? ) ) ) )",\r
- bind => [qw(black white asian yes candace jugs canyon towers)],\r
- }\r
-);\r
-\r
-for (@handle_tests) {\r
- local $" = ', '; \r
-\r
- # run twice\r
- for (my $i=0; $i < 2; $i++) {\r
- my($stmt, @bind) = DBIx::Class::SQL::Abstract->_cond_resolve($_->{where}, {});\r
-\r
- is($stmt, $_->{stmt}, 'SQL ok');\r
- cmp_ok(@bind, '==', @{$_->{bind}}, 'bind vars ok');\r
- }\r
-}\r
-\r
-\r
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff