From: Matt S Trout Date: Mon, 8 Aug 2005 22:32:17 +0000 (+0000) Subject: Finished ripping hand-hacked abstract implementation out of core X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=438adc0ee84a273f4673ad3e8e6830657bdf1142;p=dbsrgits%2FDBIx-Class-Historic.git Finished ripping hand-hacked abstract implementation out of core --- diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index f659983..556f211 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -47,7 +47,9 @@ __PACKAGE__->mk_classdata('_transform_sql_handlers' => _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; } @@ -109,6 +111,7 @@ sub transform_sql { my $h = $class->_transform_sql_handlers->{$key}; $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg; } + #warn $sql; return sprintf($sql, @args); } diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 1cff2cf..3f7aea0 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -7,9 +7,8 @@ no warnings 'qw'; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/ - Relationship InflateColumn - SQL::Abstract + Relationship PK Row Table diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index aedfa56..467e3ba 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -41,7 +41,7 @@ sub add_relationship { 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}; # @@ -51,6 +51,25 @@ sub add_relationship { 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} || ''; @@ -84,15 +103,17 @@ sub _cond_value { 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} || {}}) ); @@ -129,10 +150,10 @@ sub _query_related { $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); @@ -154,11 +175,10 @@ sub new_related { $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); } diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm deleted file mode 100644 index f176521..0000000 --- a/lib/DBIx/Class/SQL.pm +++ /dev/null @@ -1,58 +0,0 @@ -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 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 - -=head1 LICENSE - -You may distribute this code under the same terms as Perl itself. - -=cut diff --git a/lib/DBIx/Class/SQL/Abstract.pm b/lib/DBIx/Class/SQL/Abstract.pm deleted file mode 100644 index a0740c2..0000000 --- a/lib/DBIx/Class/SQL/Abstract.pm +++ /dev/null @@ -1,206 +0,0 @@ -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 for use in -generating L searches. - -=cut - -=head1 AUTHORS - -Matt S. Trout - -=head1 LICENSE - -You may distribute this code under the same terms as Perl itself. - -=cut diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index a334a19..c5e0162 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -8,7 +8,7 @@ use DBIx::Class::Storage::DBI::Cursor; 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/); @@ -93,8 +93,8 @@ sub _execute { 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); } diff --git a/t/07abstract.t b/t/07abstract.t deleted file mode 100644 index 698a51e..0000000 --- a/t/07abstract.t +++ /dev/null @@ -1,164 +0,0 @@ -use Test::More; - -plan tests => 56; - -use DBIx::Class::SQL::Abstract; - -# Make sure to test the examples, since having them break is somewhat -# embarrassing. :-( - -my @handle_tests = ( - { - where => { - requestor => 'inna', - worker => ['nwiger', 'rcwe', 'sfz'], - status => { '!=', 'completed' } - }, - stmt => "( requestor = ? AND status != ? AND ( ( worker = ? ) OR" - . " ( worker = ? ) OR ( worker = ? ) ) )", - bind => [qw/inna completed nwiger rcwe sfz/], - }, - - { - where => { - user => 'nwiger', - status => 'completed' - }, - stmt => "( status = ? AND user = ? )", - bind => [qw/completed nwiger/], - }, - - { - where => { - user => 'nwiger', - status => { '!=', 'completed' } - }, - stmt => "( status != ? AND user = ? )", - bind => [qw/completed nwiger/], - }, - - { - where => { - status => 'completed', - reportid => { 'in', [567, 2335, 2] } - }, - stmt => "( reportid IN ( ?, ?, ? ) AND status = ? )", - bind => [qw/567 2335 2 completed/], - }, - - { - where => { - status => 'completed', - reportid => { 'not in', [567, 2335, 2] } - }, - stmt => "( reportid NOT IN ( ?, ?, ? ) AND status = ? )", - bind => [qw/567 2335 2 completed/], - }, - - { - where => { - status => 'completed', - completion_date => { 'between', ['2002-10-01', '2003-02-06'] }, - }, - stmt => "( completion_date BETWEEN ? AND ? AND status = ? )", - bind => [qw/2002-10-01 2003-02-06 completed/], - }, - - { - where => [ - { - user => 'nwiger', - status => { 'in', ['pending', 'dispatched'] }, - }, - { - user => 'robot', - status => 'unassigned', - }, - ], - stmt => "( ( status IN ( ?, ? ) AND user = ? ) OR ( status = ? AND user = ? ) )", - bind => [qw/pending dispatched nwiger unassigned robot/], - }, - - { - where => { - priority => [ {'>', 3}, {'<', 1} ], - requestor => \'is not null', - }, - stmt => "( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor is not null )", - bind => [qw/3 1/], - }, - - { - where => { - priority => [ {'>', 3}, {'<', 1} ], - requestor => { '!=', undef }, - }, - stmt => "( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor IS NOT NULL )", - bind => [qw/3 1/], - }, - - { - where => { - priority => { 'between', [1, 3] }, - requestor => { 'like', undef }, - }, - stmt => "( priority BETWEEN ? AND ? AND requestor IS NULL )", - bind => [qw/1 3/], - }, - - - { - where => { - id => 1, - num => { - '<=' => 20, - '>' => 10, - }, - }, - stmt => "( id = ? AND num <= ? AND num > ? )", - bind => [qw/1 20 10/], - }, - - { - where => { foo => {-not_like => [7,8,9]}, - fum => {'like' => [qw/a b/]}, - nix => {'between' => [100,200] }, - nox => {'not between' => [150,160] }, - wix => {'in' => [qw/zz yy/]}, - wux => {'not_in' => [qw/30 40/]} - }, - 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 ( ?, ? ) )", - bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'], - }, - - # a couple of the more complex tests from S::A 01generate.t that test -nest, etc. - { - where => { name => {'like', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']}, - -nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ], - yob => {'<', 1976} ] ] }, - stmt => "( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) ) AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )", - bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)], - }, - - { - where => [-maybe => {race => [-and => [qw(black white asian)]]}, - {-nest => {firsttime => [-or => {'=','yes'}, undef]}}, - [ -and => {firstname => {-not_like => 'candace'}}, {lastname => {-in => [qw(jugs canyon towers)]}} ] ], - stmt => "( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) ) OR ( ( ( ( firsttime = ? ) OR ( firsttime IS NULL ) ) ) ) OR ( ( ( firstname NOT LIKE ? ) ) AND ( lastname IN ( ?, ?, ? ) ) ) )", - bind => [qw(black white asian yes candace jugs canyon towers)], - } -); - -for (@handle_tests) { - local $" = ', '; - - # run twice - for (my $i=0; $i < 2; $i++) { - my($stmt, @bind) = DBIx::Class::SQL::Abstract->_cond_resolve($_->{where}, {}); - - is($stmt, $_->{stmt}, 'SQL ok'); - cmp_ok(@bind, '==', @{$_->{bind}}, 'bind vars ok'); - } -} - -