-
package # Hide from PAUSE
-DBIx::Class::SQLAHacks; # Would merge upstream, but nate doesn't reply :(
-
+ DBIx::Class::SQLAHacks;
use base qw/SQL::Abstract::Limit/;
+use strict;
+use warnings;
+use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
+
+BEGIN {
+ # reinstall the carp()/croak() functions imported into SQL::Abstract
+ # as Carp and Carp::Clan do not like each other much
+ no warnings qw/redefine/;
+ no strict qw/refs/;
+ for my $f (qw/carp croak/) {
+ my $orig = \&{"SQL::Abstract::$f"};
+ *{"SQL::Abstract::$f"} = sub {
+
+ local $Carp::CarpLevel = 1; # even though Carp::Clan ignores this, $orig will not
+
+ if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+\(\) called/) {
+ __PACKAGE__->can($f)->(@_);
+ }
+ else {
+ $orig->(@_);
+ }
+ }
+ }
+}
sub new {
my $self = shift->SUPER::new(@_);
}
-
# Some databases (sqlite) do not handle multiple parenthesis
# around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
# is interpreted as x IN 1 or something similar.
return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
}
-
-
-# DB2 is the only remaining DB using this. Even though we are not sure if
-# RowNumberOver is still needed here (should be part of SQLA) leave the
-# code in place
+# Slow but ANSI standard Limit/Offset support. DB2 uses this
sub _RowNumberOver {
my ($self, $sql, $order, $rows, $offset ) = @_;
$offset += 1;
- my $last = $rows + $offset;
+ my $last = $rows + $offset - 1;
my ( $order_by ) = $self->_order_by( $order );
$sql = <<"SQL";
return $sql;
}
+# Crappy Top based Limit/Offset support. MSSQL uses this currently,
+# but may have to switch to RowNumberOver one day
+sub _Top {
+ my ( $self, $sql, $order, $rows, $offset ) = @_;
+
+ croak '$order supplied to SQLAHacks limit emulators must be a hash'
+ if (ref $order ne 'HASH');
+
+ $order = { %$order }; #copy
+
+ my $last = $rows + $offset;
+
+ my $req_order = $self->_order_by ($order->{order_by});
+
+ my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by};
+
+ delete $order->{$_} for qw/order_by _virtual_order_by/;
+ my $grpby_having = $self->_order_by ($order);
+
+ my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
+
+ $sql =~ s/^\s*(SELECT|select)//;
+
+ $sql = <<"SQL";
+ SELECT * FROM
+ (
+ SELECT TOP $rows * FROM
+ (
+ SELECT TOP $last $sql $grpby_having $order_by_inner
+ ) AS foo
+ $order_by_outer
+ ) AS bar
+ $req_order
+
+SQL
+ return $sql;
+}
+
+
# While we're at it, this should make LIMIT queries more efficient,
# without digging into things too deeply
-use Scalar::Util 'blessed';
sub _find_syntax {
my ($self, $syntax) = @_;
-
- # DB2 is the only remaining DB using this. Even though we are not sure if
- # RowNumberOver is still needed here (should be part of SQLA) leave the
- # code in place
- my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
- if(ref($self) && $dbhname && $dbhname eq 'DB2') {
- return 'RowNumberOver';
- }
-
- $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
+ return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
sub select {
my ($self, $table, $fields, $where, $order, @rest) = @_;
- if (ref $table eq 'SCALAR') {
- $table = $$table;
- }
- elsif (not ref $table) {
+
+ $self->{"${_}_bind"} = [] for (qw/having from order/);
+
+ if (not ref($table) or ref($table) eq 'SCALAR') {
$table = $self->_quote($table);
}
+
local $self->{rownum_hack_count} = 1
if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
@rest = (-1) unless defined $rest[0];
- die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
+ croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
# and anyway, SQL::Abstract::Limit will cause a barf if we don't first
- local $self->{having_bind} = [];
- my ($sql, @ret) = $self->SUPER::select(
+ my ($sql, @where_bind) = $self->SUPER::select(
$table, $self->_recurse_fields($fields), $where, $order, @rest
);
$sql .=
) :
''
;
- return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
+ return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
}
sub insert {
my $self = shift;
my $table = shift;
- $table = $self->_quote($table) unless ref($table);
+ $table = $self->_quote($table);
+
+ # SQLA will emit INSERT INTO $table ( ) VALUES ( )
+ # which is sadly understood only by MySQL. Change default behavior here,
+ # until SQLA2 comes with proper dialect support
+ if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
+ return "INSERT INTO ${table} DEFAULT VALUES"
+ }
+
$self->SUPER::insert($table, @_);
}
sub update {
my $self = shift;
my $table = shift;
- $table = $self->_quote($table) unless ref($table);
+ $table = $self->_quote($table);
$self->SUPER::update($table, @_);
}
sub delete {
my $self = shift;
my $table = shift;
- $table = $self->_quote($table) unless ref($table);
+ $table = $self->_quote($table);
$self->SUPER::delete($table, @_);
}
} @$fields);
} elsif ($ref eq 'HASH') {
foreach my $func (keys %$fields) {
+ if ($func eq 'distinct') {
+ my $_fields = $fields->{$func};
+ if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
+ croak (
+ 'The select => { distinct => ... } syntax is not supported for multiple columns.'
+ .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
+ .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
+ );
+ }
+ else {
+ $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
+ carp (
+ 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
+ ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
+ );
+ }
+ }
return $self->_sqlcase($func)
.'( '.$self->_recurse_fields($fields->{$func}).' )';
}
}
# Is the second check absolutely necessary?
elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
- return $self->_bind_to_sql( $fields );
+ return $self->_fold_sqlbind( $fields );
}
else {
- Carp::croak($ref . qq{ unexpected in _recurse_fields()})
+ croak($ref . qq{ unexpected in _recurse_fields()})
}
}
sub _order_by {
- my $self = shift;
- my $ret = '';
- my @extra;
- if (ref $_[0] eq 'HASH') {
- if (defined $_[0]->{group_by}) {
+ my ($self, $arg) = @_;
+
+ if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
+
+ my $ret = '';
+
+ if (defined $arg->{group_by}) {
$ret = $self->_sqlcase(' group by ')
- .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
+ .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
}
- if (defined $_[0]->{having}) {
- my $frag;
- ($frag, @extra) = $self->_recurse_where($_[0]->{having});
- push(@{$self->{having_bind}}, @extra);
+
+ if (defined $arg->{having}) {
+ my ($frag, @bind) = $self->_recurse_where($arg->{having});
+ push(@{$self->{having_bind}}, @bind);
$ret .= $self->_sqlcase(' having ').$frag;
}
- if (defined $_[0]->{order_by}) {
- $ret .= $self->_order_by($_[0]->{order_by});
- }
- if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
- return $self->SUPER::_order_by($_[0]);
+
+ if (defined $arg->{order_by}) {
+ my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
+ push(@{$self->{order_bind}}, @bind);
+ $ret .= $frag;
}
- } elsif (ref $_[0] eq 'SCALAR') {
- $ret = $self->_sqlcase(' order by ').${ $_[0] };
- } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
- my @order = @{+shift};
- $ret = $self->_sqlcase(' order by ')
- .join(', ', map {
- my $r = $self->_order_by($_, @_);
- $r =~ s/^ ?ORDER BY //i;
- $r;
- } @order);
- } else {
- $ret = $self->SUPER::_order_by(@_);
+
+ return $ret;
+ }
+ else {
+ my ($sql, @bind) = $self->SUPER::_order_by ($arg);
+ push(@{$self->{order_bind}}, @bind);
+ return $sql;
}
- return $ret;
}
sub _order_directions {
my ($self, $order) = @_;
- $order = $order->{order_by} if ref $order eq 'HASH';
- return $self->SUPER::_order_directions($order);
+
+ # strip bind values - none of the current _order_directions users support them
+ return $self->SUPER::_order_directions( [ map
+ { ref $_ ? $_->[0] : $_ }
+ $self->_order_by_chunks ($order)
+ ]);
}
sub _table {
return join('', @sqlf);
}
-sub _bind_to_sql {
- my $self = shift;
- my $arr = shift;
- my $sql = shift @$$arr;
- $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
- return $sql
+sub _fold_sqlbind {
+ my ($self, $sqlbind) = @_;
+
+ my @sqlbind = @$$sqlbind; # copy
+ my $sql = shift @sqlbind;
+ push @{$self->{from_bind}}, @sqlbind;
+
+ return $sql;
}
sub _make_as {
my ($self, $from) = @_;
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
- : ref $_ eq 'REF' ? $self->_bind_to_sql($_)
- : $self->_quote($_))
+ return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
+ : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
+ : $self->_quote($_))
} reverse each %{$self->_skip_options($from)});
}
for (keys %$cond) {
my $v = $cond->{$_};
if (ref $v) {
- # XXX no throw_exception() in this package and croak() fails with strange results
- Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+ croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
if ref($v) ne 'SCALAR';
$j{$_} = $v;
}
sub _quote {
my ($self, $label) = @_;
return '' unless defined $label;
+ return $$label if ref($label) eq 'SCALAR';
return "*" if $label eq '*';
return $label unless $self->{quote_char};
if(ref $self->{quote_char} eq "ARRAY"){
=head1 NAME
-DBIx::Class::SQLAHacks - Things desired to be merged into SQL::Abstract
+DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
+and includes a number of DBIC-specific workarounds, not yet suitable for
+inclusion into SQLA proper.
=head1 METHODS
projects / dbsrgits/DBIx-Class.git / blobdiff