2007/4/14, Oleg Pronin <[EMAIL PROTECTED]>:
This can be solved with operator overloading. There is a very good idea in
module 'ORM' (another DB abstraction module). Please see its docs (
http://search.cpan.org/~akimov/ORM-0.85/lib/ORM.pod) for information.
Thus this module is less powerfull then DBIx-Class, there are some cool
things. I think this would be great to merge this ideas with DBIx-Class.
Actually I have already written a patch :-) There is
SQL::Abstract::_recurse_where sub, which does all stuff. I've added
two syntactic constructs there.
my %where = (
first_name => { like => 'J%' },
wedding_datetime => { '<' => \'NOW()' },
);
Which produces
$stmt = "WHERE ( first_name LIKE ? AND wedding_datetime < ( NOW() ) )";
@bind = ('J%');
And
$where = (
birth_date => { '>' => [ \'CURDATE() - INTERVAL ? YEAR', 27 ] },
sex => 'male',
);
Which results in:
$stmt = "WHERE ( birth_date > ( CURDATE() - INTERVAL ? YEAR )
AND sex = ? )";
@bind = qw/27 male/;
I've made a subclass of DBIx::Class::Storage::DBI, which implements
its own sql_maker with this sub overriden. I'm just confused how to
make this stuff work to keep profit of automated determination of SQL
dialect. When I make my DBIx::Class::Storage class inherit from
DBIx::Class::Storage::DBI:BindExpressions, I get errors like:
Can't locate DBI object method "last_insert_rowid" via package
"DBD::mysql::db" at
/usr/local/lib/perl5/site_perl/5.8.8/DBIx/Class/Storage/DBI.pm line 964,
<DATA> line 1.
I have a feeling this can be resolved by proper subclassing and, may
be, load_components calls. See module code below.
Also I've written a patch for SQL::Abstract and wrote a message to
Nate Wiger, if he looks forward to include these enhancements directly
in SQL::Abstract.
Regards,
Ivan
package DBIx::Class::Storage::DBI::BindExpressions;
use strict;
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
__PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class/);
sub new {
my $class = shift;
my $new = $class->next::method(@_);
$new->{sql_maker_class} ||= 'DBIC::SQL::Abstract::BindExpressions';
return $new;
}
sub sql_maker {
my ($self) = @_;
unless ($self->_sql_maker) {
$self->_sql_maker($self->{sql_maker_class}->new(
limit_dialect => $self->dbh,
) );
}
return $self->_sql_maker;
}
BEGIN {
package DBIC::SQL::Abstract::BindExpressions;
use base qw/DBIC::SQL::Abstract/;
sub _recurse_where {
local $^W = 0; # really, you've gotta be fucking kidding me
my $self = shift;
my $where = SQL::Abstract::_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') {
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;
} 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 $u = $self->_modlogic($1 . $2);
$self->_debug("HASH($f => $x) uses
special operator: [ $u ]");
if ($u =~ /between/i) {
# SQL sucks
push @sqlf, join ' ',
$self->_convert($label), $u, $self->_convert('?'),
$self->_sqlcase('and'), $self->_convert('?');
} else {
push @sqlf, join ' ',
$self->_convert($label), $u, '(',
join(', ', map {
$self->_convert('?') } @$x),
')';
}
push @sqlv, $self->_bindtype($k, @$x);
} elsif (ref $x->[0] eq 'SCALAR') {
my ($stmt, @bind) = @$x;
# { '<' => [ \'NOW() - INTERVAL ? DAY', 1 ] }
$self->_debug("ARRAY($x) means literal
SQL with bind params: $$stmt : @bind");
push @sqlf, join(' ', $self->_convert($label),
$self->_sqlcase($f),
'(',
$self->_sqlcase($$stmt), ')');
push @sqlv, @bind;
} else {
# 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;
}
} elsif (ref $x eq 'SCALAR') {
# { start_datetime => { '<' => \'NOW()' } }
$self->_debug("HASH($f => $x) means literal SQL: $$x");
push @sqlf, join(' ', $self->_convert($label),
$self->_sqlcase($f),
'(', $self->_sqlcase($$x), ')');
} 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;
}
}
1;
_______________________________________________
List: http://lists.rawmode.org/cgi-bin/mailman/listinfo/dbix-class
Wiki: http://dbix-class.shadowcatsystems.co.uk/
IRC: irc.perl.org#dbix-class
SVN: http://dev.catalyst.perl.org/repos/bast/trunk/DBIx-Class/
Searchable Archive: http://www.mail-archive.com/[EMAIL PROTECTED]/
