X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=3208a766fcde46384395e658022190b5a5fc4035;hb=6553ac3837081c481ecdf269c7aff407c348a807;hp=4cbbcc62d2d0927defeebd0c0bedca6ca617839f;hpb=fd4cb60a0c582000de4beef5ba7a519fd531e168;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index 4cbbcc6..3208a76 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -1,9 +1,39 @@ package # Hide from PAUSE 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 the +# SQLA core + use base qw/SQL::Abstract::Limit/; -use Carp::Clan qw/^DBIx::Class/; +use strict; +use warnings; +use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/; +use Sub::Name(); + +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::Name::subname "SQL::Abstract::$f" => + sub { + if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) { + __PACKAGE__->can($f)->(@_); + } + else { + goto $orig; + } + }; + } +} + +# Tries to determine limit dialect. +# sub new { my $self = shift->SUPER::new(@_); @@ -17,110 +47,245 @@ sub 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. -# -# Since we currently do not have access to the SQLA AST, resort -# to barbaric mutilation of any SQL supplied in literal form +# ANSI standard Limit/Offset implementation. DB2 and MSSQL use this +sub _RowNumberOver { + my ($self, $sql, $order, $rows, $offset ) = @_; -sub _strip_outer_paren { - my ($self, $arg) = @_; + # get the order_by only (or make up an order if none exists) + my $order_by = $self->_order_by( + (delete $order->{order_by}) || \ '(SELECT (1))' + ); + + # whatever is left + my $group_having = $self->_order_by($order); + + $sql = sprintf (<<'EOS', $order_by, $sql, $group_having, $offset + 1, $offset + $rows, ); + +SELECT * FROM ( + SELECT orig_query.*, ROW_NUMBER() OVER(%s ) AS rno__row__index FROM (%s%s) orig_query +) rno_subq WHERE rno__row__index BETWEEN %d AND %d + +EOS - 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 - }, - }); + $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger + return $sql; } -sub __strip_outer_paren { - my $sql = shift; +# Crappy Top based Limit/Offset support. Legacy from MSSQL. +sub _Top { + my ( $self, $sql, $order, $rows, $offset ) = @_; + + # mangle the input sql so it can be properly aliased in the outer queries + $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix + or croak "Unrecognizable SELECT: $sql"; + my $sql_select = $1; + my @sql_select = split (/\s*,\s*/, $sql_select); + + # we can't support subqueries (in fact MSSQL can't) - croak + if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) { + croak (sprintf ( + 'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while ' + . 'the resultset select attribure contains %d elements: %s', + scalar @sql_select, + scalar @{$self->{_dbic_rs_attrs}{select}}, + $sql_select, + )); + } + + my $name_sep = $self->name_sep || '.'; + my $esc_name_sep = "\Q$name_sep\E"; + my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x; + + my $rs_alias = $self->{_dbic_rs_attrs}{alias}; + my $quoted_rs_alias = $self->_quote ($rs_alias); + + # construct the new select lists, rename(alias) some columns if necessary + my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases); + + for (@{$self->{_dbic_rs_attrs}{select}}) { + next if ref $_; + my ($table, $orig_colname) = ( $_ =~ $col_re ); + next unless $table; + $seen_names{$orig_colname}++; + } + + for my $i (0 .. $#sql_select) { + + my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i]; + my $colsel_sql = $sql_select[$i]; - if ($sql and not ref $sql) { - while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) { - $sql = $1; + # this may or may not work (in case of a scalarref or something) + my ($table, $orig_colname) = ( $colsel_arg =~ $col_re ); + + my $quoted_alias; + # do not attempt to understand non-scalar selects - alias numerically + if (ref $colsel_arg) { + $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) ); + } + # column name seen more than once - alias it + elsif ($orig_colname && + ($seen_names{$orig_colname} && $seen_names{$orig_colname} > 1) ) { + $quoted_alias = $self->_quote ("${table}__${orig_colname}"); + } + + # we did rename - make a record and adjust + if ($quoted_alias) { + # alias inner + push @inner_select, "$colsel_sql AS $quoted_alias"; + + # push alias to outer + push @outer_select, $quoted_alias; + + # Any aliasing accumulated here will be considered + # both for inner and outer adjustments of ORDER BY + $self->__record_alias ( + \%col_aliases, + $quoted_alias, + $colsel_arg, + $table ? $orig_colname : undef, + ); + } + + # otherwise just leave things intact inside, and use the abbreviated one outside + # (as we do not have table names anymore) + else { + push @inner_select, $colsel_sql; + + my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work + push @outer_select, $outer_quoted; + $self->__record_alias ( + \%outer_col_aliases, + $outer_quoted, + $colsel_arg, + $table ? $orig_colname : undef, + ); } } - return $sql; -} + my $outer_select = join (', ', @outer_select ); + my $inner_select = join (', ', @inner_select ); -sub _where_field_IN { - my ($self, $lhs, $op, $rhs) = @_; - $rhs = $self->_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_IN ($lhs, $op, $rhs); -} + %outer_col_aliases = (%outer_col_aliases, %col_aliases); -sub _where_field_BETWEEN { - my ($self, $lhs, $op, $rhs) = @_; - $rhs = $self->_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs); -} + # deal with order + croak '$order supplied to SQLAHacks limit emulators must be a hash' + if (ref $order ne 'HASH'); + $order = { %$order }; #copy + my $req_order = $order->{order_by}; -# 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 ) = @_; + # examine normalized version, collapses nesting + my $limit_order; + if (scalar $self->_order_by_chunks ($req_order)) { + $limit_order = $req_order; + } + else { + $limit_order = [ map + { join ('', $rs_alias, $name_sep, $_ ) } + ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns ) + ]; + } + + my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order); + my $order_by_requested = $self->_order_by ($req_order); + + # generate the rest + delete $order->{order_by}; + my $grpby_having = $self->_order_by ($order); + + # short circuit for counts - the ordering complexity is needless + if ($self->{_dbic_rs_attrs}{-for_count_only}) { + return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer"; + } + + # we can't really adjust the order_by columns, as introspection is lacking + # resort to simple substitution + for my $col (keys %outer_col_aliases) { + for ($order_by_requested, $order_by_outer) { + $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g; + } + } + for my $col (keys %col_aliases) { + $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g; + } + + + my $inner_lim = $rows + $offset; - $offset += 1; - my $last = $rows + $offset; - my ( $order_by ) = $self->_order_by( $order ); + $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner"; - $sql = <<"SQL"; -SELECT * FROM -( - SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM ( + if ($offset) { + $sql = <<"SQL"; + + SELECT TOP $rows $outer_select FROM + ( $sql - $order_by - ) Q1 -) Q2 -WHERE ROW_NUM BETWEEN $offset AND $last + ) $quoted_rs_alias + $order_by_outer +SQL + + } + + if ($order_by_requested) { + $sql = <<"SQL"; + SELECT $outer_select FROM + ( $sql ) $quoted_rs_alias + $order_by_requested SQL + } + + $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line return $sql; } +# action at a distance to shorten Top code above +sub __record_alias { + my ($self, $register, $alias, $fqcol, $col) = @_; + + # record qualified name + $register->{$fqcol} = $alias; + $register->{$self->_quote($fqcol)} = $alias; + + return unless $col; + + # record unqualified name, undef (no adjustment) if a duplicate is found + if (exists $register->{$col}) { + $register->{$col} = undef; + } + else { + $register->{$col} = $alias; + } + + $register->{$self->_quote($col)} = $register->{$col}; +} + + # 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); } +my $for_syntax = { + update => 'FOR UPDATE', + shared => 'FOR SHARE', +}; +# Quotes table names, handles "limit" dialects (e.g. where rownum between x and +# y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE. 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) { + $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]; @@ -129,36 +294,42 @@ sub select { 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; + if (my $for = delete $self->{_dbic_rs_attrs}{for}) { + $sql .= " $for_syntax->{$for}" if $for_syntax->{$for}; + } + + return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql; } +# Quotes table names, and handles default inserts 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, @_); } +# Just quotes table names. sub update { my $self = shift; my $table = shift; - $table = $self->_quote($table) unless ref($table); + $table = $self->_quote($table); $self->SUPER::update($table, @_); } +# Just quotes table names. sub delete { my $self = shift; my $table = shift; - $table = $self->_quote($table) unless ref($table); + $table = $self->_quote($table); $self->SUPER::delete($table, @_); } @@ -184,28 +355,37 @@ sub _recurse_fields { ? ' 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 "Unsupported syntax, 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 }"; - } - } - - return $self->_sqlcase($func) - .'( '.$self->_recurse_fields($fields->{$func}).' )'; + } + elsif ($ref eq 'HASH') { + my %hash = %$fields; + + my $as = delete $hash{-as}; # if supplied + + my ($func, $args) = each %hash; + delete $hash{$func}; + + 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'), $as) + : '' + ); + + # there should be nothing left + if (keys %hash) { + croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ); } + + return $select; } # Is the second check absolutely necessary? elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { @@ -217,75 +397,45 @@ 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 }); + my ($self, $arg) = @_; + + if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) { + + my $ret = ''; + + if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) { + $ret = $self->_sqlcase(' group by ') . $g; } - 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'; - if (ref $order eq 'HASH') { - $order = [$self->_order_directions_hash($order)]; - } elsif (ref $order eq 'ARRAY') { - $order = [map { - if (ref $_ eq 'HASH') { - $self->_order_directions_hash($_); - } else { - $_; - } - } @{ $order }]; - } - return $self->SUPER::_order_directions($order); -} -sub _order_directions_hash { - my ($self, $order) = @_; - if (grep { $_ =~ /^-(desc|asc)/i } keys %{$order}) { - return map { - my $key = $_; - my @tmp; - s/^-(desc|asc)/\1/i; - my $dir = $_; - if (ref $order->{ $key } eq 'ARRAY') { - @tmp = map "$_ $dir", @{ $order->{ $key } }; - } else { # should be scalar - @tmp = ( "$order->{$key} $dir" ); - } - @tmp; - } keys %{$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 { @@ -311,15 +461,21 @@ 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; + + my $join_clause = sprintf ('%s JOIN ', + $join_type ? ' ' . uc($join_type) : '' + ); + push @sqlf, $join_clause; if (ref $to eq 'ARRAY') { push(@sqlf, '(', $self->_recurse_from(@$to), ')'); @@ -333,8 +489,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; } @@ -380,6 +539,7 @@ sub _join_condition { 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"){ @@ -399,12 +559,15 @@ sub limit_dialect { return $self->{limit_dialect}; } +# Set to an array-ref to specify separate left and right quotes for table names. +# A single scalar is equivalen to [ $char, $char ] sub quote_char { my $self = shift; $self->{quote_char} = shift if @_; return $self->{quote_char}; } +# Character separating quoted table names. sub name_sep { my $self = shift; $self->{name_sep} = shift if @_; @@ -412,50 +575,3 @@ sub 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 -