X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=a1e6d1cbf1aa41888c00a523b6ae7e0207e91769;hb=4a80eede246c6cb2da4b15bcc00dbd6e56058c89;hp=1498be1414b5e026edb5c6f61389f07efce42146;hpb=b1e1d07360d6a1921358cf3952894c19faf14cea;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index 1498be1..a1e6d1c 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -1,6 +1,10 @@ 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 strict; use warnings; @@ -12,12 +16,13 @@ BEGIN { 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/) { + if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) { __PACKAGE__->can($f)->(@_); } else { @@ -27,6 +32,9 @@ BEGIN { } } + +# Tries to determine limit dialect. +# sub new { my $self = shift->SUPER::new(@_); @@ -39,14 +47,12 @@ sub new { $self; } - # Some databases (sqlite) do not handle multiple parenthesis -# around in/between arguments. A tentative x IN ( ( 1, 2 ,3) ) +# 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) = @_; @@ -119,44 +125,93 @@ sub _Top { # 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 $select = $1; + 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 (@outer_select, %col_index); - for my $selected_col (@{$self->{_dbic_rs_attrs}{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 $new_colname; + my $rs_alias = $self->{_dbic_rs_attrs}{alias}; + my $quoted_rs_alias = $self->_quote ($rs_alias); - if (ref $selected_col) { - $new_colname = $self->_quote ('column_' . (@outer_select + 1) ); - } - else { - my $quoted_col = $self->_quote ($selected_col); + # construct the new select lists, rename(alias) some columns if necessary + my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases); - my $name_sep = $self->name_sep || '.'; - $name_sep = "\Q$name_sep\E"; + for (@{$self->{_dbic_rs_attrs}{select}}) { + next if ref $_; + my ($table, $orig_colname) = ( $_ =~ $col_re ); + next unless $table; + $seen_names{$orig_colname}++; + } - my ($table, $orig_colname) = ( $selected_col =~ / (?: (.+) $name_sep )? ([^$name_sep]+) $ /x ); - $new_colname = $self->_quote ("${table}__${orig_colname}"); + for my $i (0 .. $#sql_select) { - $select =~ s/(\Q$quoted_col\E|\Q$selected_col\E)/"$1 AS $new_colname"/e; + my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i]; + my $colsel_sql = $sql_select[$i]; - # record qualified name if available (should be) - $col_index{$selected_col} = $new_colname if $table; + # this may or may not work (in case of a scalarref or something) + my ($table, $orig_colname) = ( $colsel_arg =~ $col_re ); - # record unqialified name, undef if a duplicate is found - if (exists $col_index{$orig_colname}) { - $col_index{$orig_colname} = undef; - } - else { - $col_index{$orig_colname} = $new_colname; - } + 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} > 1) ) { + $quoted_alias = $self->_quote ("${table}__${orig_colname}"); } - push @outer_select, $new_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, + ); + } } my $outer_select = join (', ', @outer_select ); + my $inner_select = join (', ', @inner_select ); + %outer_col_aliases = (%outer_col_aliases, %col_aliases); # deal with order croak '$order supplied to SQLAHacks limit emulators must be a hash' @@ -164,51 +219,95 @@ sub _Top { $order = { %$order }; #copy - my $req_order = [ $self->_order_by_chunks ($order->{order_by}) ]; - my $limit_order = [ @$req_order ? @$req_order : $self->_order_by_chunks ($order->{_virtual_order_by}) ]; - + my $req_order = $order->{order_by}; - # normalize all column names in order by - # no copies, just aliasing ($_) - for ($req_order, $limit_order) { - for ( @{$_ || []} ) { - $_ = $col_index{$_} if $col_index{$_}; - } + # 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->{$_} for qw/order_by _virtual_order_by/; + delete $order->{order_by}; my $grpby_having = $self->_order_by ($order); - my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_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 $last = $rows + $offset; - $sql = <<"SQL"; + my $inner_lim = $rows + $offset; + + $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner"; + + if ($offset) { + $sql = <<"SQL"; SELECT TOP $rows $outer_select FROM ( - SELECT TOP $last $select $sql $grpby_having $order_by_inner - ) AS inner_sel + $sql + ) $quoted_rs_alias $order_by_outer SQL - if (@$req_order) { - my $order_by_requested = $self->_order_by ($req_order); + } + if ($order_by_requested) { $sql = <<"SQL"; - SELECT $outer_select FROM - ( $sql ) AS outer_sel - $order_by_requested; + 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, @@ -222,6 +321,8 @@ 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) = @_; @@ -248,6 +349,7 @@ sub select { 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; @@ -263,6 +365,7 @@ sub insert { $self->SUPER::insert($table, @_); } +# Just quotes table names. sub update { my $self = shift; my $table = shift; @@ -270,6 +373,7 @@ sub update { $self->SUPER::update($table, @_); } +# Just quotes table names. sub delete { my $self = shift; my $table = shift; @@ -299,28 +403,39 @@ 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 ( - '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 }" - ); - } + } + elsif ($ref eq 'HASH') { + my %hash = %$fields; + my ($select, $as); + + if ($hash{-select}) { + $select = $self->_recurse_fields (delete $hash{-select}); + $as = $self->_quote (delete $hash{-as}); + } + else { + 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 }' + ); } - return $self->_sqlcase($func) - .'( '.$self->_recurse_fields($fields->{$func}).' )'; + $select = sprintf ('%s( %s )', + $self->_sqlcase($func), + $self->_recurse_fields($args) + ); } + + # there should be nothing left + if (keys %hash) { + croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ); + } + + $select .= " AS $as" if $as; + return $select; } # Is the second check absolutely necessary? elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { @@ -338,9 +453,8 @@ sub _order_by { my $ret = ''; - if (defined $arg->{group_by}) { - $ret = $self->_sqlcase(' group by ') - .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }); + if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) { + $ret = $self->_sqlcase(' group by ') . $g; } if (defined $arg->{having}) { @@ -488,12 +602,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 @_; @@ -501,50 +618,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 -