X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=31e189a255d17127c3ad0af13518443ff496f3bb;hb=7fca91be5671c61be5c766bd93df741bc00d9c15;hp=63834e321be199d314fd1a7f59c3ec915fd69199;hpb=fde3719aca80cb4012aea1391758d629250289fc;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index 63834e3..31e189a 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -1,215 +1,172 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks; -use base qw/SQL::Abstract::Limit/; +# This module is a subclass of SQL::Abstract and includes a number of +# DBIC-specific workarounds, not yet suitable for inclusion into the +# SQLA core. +# It also provides all (and more than) the functionality of +# SQL::Abstract::Limit, which proved to be very hard to keep updated + +use base qw/ + DBIx::Class::SQLAHacks::LimitDialects + SQL::Abstract + Class::Accessor::Grouped +/; +use mro 'c3'; use strict; use warnings; -use Carp::Clan qw/^DBIx::Class/; - -sub new { - my $self = shift->SUPER::new(@_); - - # This prevents the caching of $dbh in S::A::L, I believe - # If limit_dialect is a ref (like a $dbh), go ahead and replace - # it with what it resolves to: - $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect}) - if ref $self->{limit_dialect}; - - $self; +use Sub::Name 'subname'; +use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/; +use namespace::clean; + +__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); + +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"}; + my $clan_import = \&{$f}; + *{"SQL::Abstract::$f"} = subname "SQL::Abstract::$f" => + sub { + if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) { + $clan_import->(@_); + } + else { + goto $orig; + } + }; + } } +# the "oh noes offset/top without limit" constant +# limited to 32 bits for sanity (and consistency, +# since it is ultimately handed to sprintf %u) +# Implemented as a method, since ::Storage::DBI also +# refers to it (i.e. for the case of software_limit or +# as the value to abuse with MSSQL ordered subqueries) +sub __max_int { 0xFFFFFFFF }; -# 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. -# -# Since we currently do not have access to the SQLA AST, resort -# to barbaric mutilation of any SQL supplied in literal form - -sub _strip_outer_paren { - my ($self, $arg) = @_; +# Handle limit-dialect selection +sub select { + my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; - return $self->_SWITCH_refkind ($arg, { - ARRAYREFREF => sub { - $$arg->[0] = __strip_outer_paren ($$arg->[0]); - return $arg; - }, - SCALARREF => sub { - return \__strip_outer_paren( $$arg ); - }, - FALLBACK => sub { - return $arg - }, - }); -} -sub __strip_outer_paren { - my $sql = shift; + $fields = $self->_recurse_fields($fields); - if ($sql and not ref $sql) { - while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) { - $sql = $1; - } + if (defined $offset) { + croak ('A supplied offset must be a non-negative integer') + if ( $offset =~ /\D/ or $offset < 0 ); } + $offset ||= 0; - return $sql; -} - -sub _where_field_IN { - my ($self, $lhs, $op, $rhs) = @_; - $rhs = $self->_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_IN ($lhs, $op, $rhs); -} - -sub _where_field_BETWEEN { - my ($self, $lhs, $op, $rhs) = @_; - $rhs = $self->_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs); -} - + if (defined $limit) { + croak ('A supplied limit must be a positive integer') + if ( $limit =~ /\D/ or $limit <= 0 ); + } + elsif ($offset) { + $limit = $self->__max_int; + } -# 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 -sub _RowNumberOver { - my ($self, $sql, $order, $rows, $offset ) = @_; + my ($sql, @bind); + if ($limit) { + # this is legacy code-flow from SQLA::Limit, it is not set in stone - $offset += 1; - my $last = $rows + $offset - 1; - my ( $order_by ) = $self->_order_by( $order ); + ($sql, @bind) = $self->next::method ($table, $fields, $where); - $sql = <<"SQL"; -SELECT * FROM -( - SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM ( - $sql - $order_by - ) Q1 -) Q2 -WHERE ROW_NUM BETWEEN $offset AND $last + my $limiter = + $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit + || + do { + my $dialect = $self->limit_dialect + or croak "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found"; + $self->can ("_$dialect") + or croak "SQLAHacks does not implement the requested dialect '$dialect'"; + } + ; -SQL + $sql = $self->$limiter ($sql, $rs_attrs, $limit, $offset); + } + else { + ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs); + } - return $sql; -} + push @{$self->{where_bind}}, @bind; +# this *must* be called, otherwise extra binds will remain in the sql-maker + my @all_bind = $self->_assemble_binds; -# 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) { - if ($dbhname eq 'DB2') { - return 'RowNumberOver'; - } - } - - $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax); + return wantarray ? ($sql, @all_bind) : $sql; } -sub select { - my ($self, $table, $fields, $where, $order, @rest) = @_; - local $self->{having_bind} = []; - local $self->{from_bind} = []; - - if (ref $table eq 'SCALAR') { - $table = $$table; - } - elsif (not ref $table) { - $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]; - croak "LIMIT 0 Does Not Compute" if $rest[0] == 0; - # and anyway, SQL::Abstract::Limit will cause a barf if we don't first - my ($sql, @where_bind) = $self->SUPER::select( - $table, $self->_recurse_fields($fields), $where, $order, @rest - ); - $sql .= - $self->{for} ? - ( - $self->{for} eq 'update' ? ' FOR UPDATE' : - $self->{for} eq 'shared' ? ' FOR SHARE' : - '' - ) : - '' - ; - return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}) : $sql; +sub _assemble_binds { + my $self = shift; + return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/from where having order/); } +# Handle default inserts sub insert { - my $self = shift; - my $table = shift; - $table = $self->_quote($table) unless ref($table); - $self->SUPER::insert($table, @_); -} +# optimized due to hotttnesss +# my ($self, $table, $data, $options) = @_; -sub update { - my $self = shift; - my $table = shift; - $table = $self->_quote($table) unless ref($table); - $self->SUPER::update($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 (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) { + my $sql = "INSERT INTO $_[1] DEFAULT VALUES"; -sub delete { - my $self = shift; - my $table = shift; - $table = $self->_quote($table) unless ref($table); - $self->SUPER::delete($table, @_); -} + if (my $ret = ($_[3]||{})->{returning} ) { + $sql .= $_[0]->_insert_returning ($ret); + } -sub _emulate_limit { - my $self = shift; - if ($_[3] == -1) { - return $_[1].$self->_order_by($_[2]); - } else { - return $self->SUPER::_emulate_limit(@_); + return $sql; } + + next::method(@_); } sub _recurse_fields { - my ($self, $fields, $params) = @_; + my ($self, $fields) = @_; my $ref = ref $fields; return $self->_quote($fields) unless $ref; return $$fields if $ref eq 'SCALAR'; if ($ref eq 'ARRAY') { - return join(', ', map { - $self->_recurse_fields($_) - .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack}) - ? ' AS col'.$self->{rownum_hack_count}++ - : '') - } @$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}).' )'; + return join(', ', map { $self->_recurse_fields($_) } @$fields); + } + elsif ($ref eq 'HASH') { + my %hash = %$fields; # shallow copy + + my $as = delete $hash{-as}; # if supplied + + my ($func, $args, @toomany) = %hash; + + # there should be only one pair + if (@toomany) { + croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ); } + + if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) { + croak ( + 'The select => { distinct => ... } syntax is not supported for multiple columns.' + .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }' + .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }' + ); + } + + my $select = sprintf ('%s( %s )%s', + $self->_sqlcase($func), + $self->_recurse_fields($args), + $as + ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) + : '' + ); + + return $select; } # Is the second check absolutely necessary? elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { @@ -220,107 +177,80 @@ sub _recurse_fields { } } -sub _order_by { - my $self = shift; - my $ret = ''; - my @extra; - if (ref $_[0] eq 'HASH') { - if (defined $_[0]->{group_by}) { - $ret = $self->_sqlcase(' group by ') - .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 }); - } - if (defined $_[0]->{having}) { - my $frag; - ($frag, @extra) = $self->_recurse_where($_[0]->{having}); - push(@{$self->{having_bind}}, @extra); - $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]); - } - } 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; -} +my $for_syntax = { + update => 'FOR UPDATE', + shared => 'FOR SHARE', +}; + +# this used to be a part of _order_by but is broken out for clarity. +# What we have been doing forever is hijacking the $order arg of +# SQLA::select to pass in arbitrary pieces of data (first the group_by, +# then pretty much the entire resultset attr-hash, as more and more +# things in the SQLA space need to have mopre info about the $rs they +# create SQL for. The alternative would be to keep expanding the +# signature of _select with more and more positional parameters, which +# is just gross. All hail SQLA2! +sub _parse_rs_attrs { + my ($self, $arg) = @_; -sub _order_directions { - my ($self, $order) = @_; - return $self->SUPER::_order_directions( $self->_resolve_order($order) ); -} + my $sql = ''; -sub _resolve_order { - my ($self, $order) = @_; - $order = $order->{order_by} if (ref $order eq 'HASH' and $order->{order_by}); + if (my $g = $self->_recurse_fields($arg->{group_by}) ) { + $sql .= $self->_sqlcase(' group by ') . $g; + } - if (ref $order eq 'HASH') { - $order = [$self->_resolve_order_hash($order)]; + if (defined $arg->{having}) { + my ($frag, @bind) = $self->_recurse_where($arg->{having}); + push(@{$self->{having_bind}}, @bind); + $sql .= $self->_sqlcase(' having ') . $frag; } - elsif (ref $order eq 'ARRAY') { - $order = [map { - if (ref ($_) eq 'SCALAR') { - $$_ - } - elsif (ref ($_) eq 'HASH') { - $self->_resolve_order_hash($_) - } - else { - $_ - } - } @$order]; + + if (defined $arg->{order_by}) { + $sql .= $self->_order_by ($arg->{order_by}); + } + + if (my $for = $arg->{for}) { + $sql .= " $for_syntax->{$for}" if $for_syntax->{$for}; } - return $order; + return $sql; } -sub _resolve_order_hash { - my ($self, $order) = @_; - my @new_order; - foreach my $key (keys %{ $order }) { - if ($key =~ /^-(desc|asc)/i ) { - my $direction = $1; - my $type = ref $order->{ $key }; - if ($type eq 'ARRAY') { - push @new_order, map( "$_ $direction", @{ $order->{ $key } } ); - } elsif (!$type) { - push @new_order, "$order->{$key} $direction"; - } else { - croak "hash order_by can only contain Scalar or Array, not $type"; - } - } else { - croak "$key is not a valid direction, use -asc or -desc"; - } +sub _order_by { + my ($self, $arg) = @_; + + # check that we are not called in legacy mode (order_by as 4th argument) + if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) { + return $self->_parse_rs_attrs ($arg); + } + else { + my ($sql, @bind) = $self->next::method($arg); + push @{$self->{order_bind}}, @bind; + return $sql; } - return @new_order; } sub _table { - my ($self, $from) = @_; - if (ref $from eq 'ARRAY') { - return $self->_recurse_from(@$from); - } elsif (ref $from eq 'HASH') { - return $self->_make_as($from); - } else { - return $from; # would love to quote here but _table ends up getting called - # twice during an ->select without a limit clause due to - # the way S::A::Limit->select works. should maybe consider - # bypassing this and doing S::A::select($self, ...) in - # our select method above. meantime, quoting shims have - # been added to select/insert/update/delete here +# optimized due to hotttnesss +# my ($self, $from) = @_; + if (my $ref = ref $_[1] ) { + if ($ref eq 'ARRAY') { + return $_[0]->_recurse_from(@{$_[1]}); + } + elsif ($ref eq 'HASH') { + return $_[0]->_make_as($_[1]); + } } + + return $_[0]->next::method ($_[1]); +} + +sub _generate_join_clause { + my ($self, $join_type) = @_; + + return sprintf ('%s JOIN ', + $join_type ? ' ' . uc($join_type) : '' + ); } sub _recurse_from { @@ -330,15 +260,18 @@ sub _recurse_from { foreach my $j (@join) { my ($to, $on) = @$j; + # check whether a join type exists - my $join_clause = ''; my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; - if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) { - $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN '; - } else { - $join_clause = ' JOIN '; + my $join_type; + if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) { + $join_type = $to_jt->{-join_type}; + $join_type =~ s/^\s+ | \s+$//xg; } - push(@sqlf, $join_clause); + + $join_type = $self->{_default_jointype} if not defined $join_type; + + push @sqlf, $self->_generate_join_clause( $join_type ); if (ref $to eq 'ARRAY') { push(@sqlf, '(', $self->_recurse_from(@$to), ')'); @@ -395,89 +328,8 @@ sub _join_condition { } elsif (ref $cond eq 'ARRAY') { return join(' OR ', map { $self->_join_condition($_) } @$cond); } else { - die "Can't handle this yet!"; + croak "Can't handle this yet!"; } } -sub _quote { - my ($self, $label) = @_; - return '' unless defined $label; - return "*" if $label eq '*'; - return $label unless $self->{quote_char}; - if(ref $self->{quote_char} eq "ARRAY"){ - return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1] - if !defined $self->{name_sep}; - my $sep = $self->{name_sep}; - return join($self->{name_sep}, - map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] } - split(/\Q$sep\E/,$label)); - } - return $self->SUPER::_quote($label); -} - -sub limit_dialect { - my $self = shift; - $self->{limit_dialect} = shift if @_; - return $self->{limit_dialect}; -} - -sub quote_char { - my $self = shift; - $self->{quote_char} = shift if @_; - return $self->{quote_char}; -} - -sub name_sep { - my $self = shift; - $self->{name_sep} = shift if @_; - return $self->{name_sep}; -} - 1; - -__END__ - -=pod - -=head1 NAME - -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 - -=head2 new - -Tries to determine limit dialect. - -=head2 select - -Quotes table names, handles "limit" dialects (e.g. where rownum between x and -y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE. - -=head2 insert update delete - -Just quotes table names. - -=head2 limit_dialect - -Specifies the dialect of used for implementing an SQL "limit" clause for -restricting the number of query results returned. Valid values are: RowNum. - -See L for details. - -=head2 name_sep - -Character separating quoted table names. - -See L for details. - -=head2 quote_char - -Set to an array-ref to specify separate left and right quotes for table names. - -See L for details. - -=cut -