X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=a454cd5f6948f8ef6bf8691a2b4bdc66b333724b;hb=a6866b9b686be40e9cc70cdf67c436c6138f75f5;hp=9fb3c242788171545f05d1ab233bfbcfb1d9e4f7;hpb=e8fcf76f98ebd3cc99638765220d0024380bdd02;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index 9fb3c24..a454cd5 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -2,7 +2,30 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks; use base qw/SQL::Abstract::Limit/; -use Carp::Clan qw/^DBIx::Class/; +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(@_); @@ -65,16 +88,12 @@ sub _where_field_BETWEEN { 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"; @@ -92,28 +111,57 @@ 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) = @_; - local $self->{having_bind} = []; - local $self->{from_bind} = []; + + $self->{"${_}_bind"} = [] for (qw/having from order/); if (ref $table eq 'SCALAR') { $table = $$table; @@ -138,13 +186,21 @@ sub select { ) : '' ; - return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$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); + + # 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, @_); } @@ -189,20 +245,20 @@ sub _recurse_fields { if ($func eq 'distinct') { my $_fields = $fields->{$func}; if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) { - croak "Unsupported syntax, please use " . - "{ group_by => [ qw/" . (join ' ', @$_fields) . "/ ] }" . - " or " . - "{ select => [ qw/" . (join ' ', @$_fields) . "/ ], distinct => 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 "This syntax will be deprecated in 09, please use " . - "{ group_by => '${_fields}' }" . - " or " . - "{ select => '${_fields}', distinct => 1 }"; + 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}).' )'; } @@ -217,46 +273,46 @@ sub _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 { @@ -304,8 +360,11 @@ sub _recurse_from { sub _fold_sqlbind { my ($self, $sqlbind) = @_; - my $sql = shift @$$sqlbind; - push @{$self->{from_bind}}, @$$sqlbind; + + my @sqlbind = @$$sqlbind; # copy + my $sql = shift @sqlbind; + push @{$self->{from_bind}}, @sqlbind; + return $sql; }