X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=172136b7130da8e32c4bf1a846c0b3d4fb588785;hb=a07bb26c5bd12b153223d88d76e018b6690df785;hp=ba892644f637a6a455768f81ee577c252f6a129a;hpb=64c7c000587e6e6dccb9fc6330a66dcebd1f3695;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index ba89264..172136b 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -1,10 +1,15 @@ 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; use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/; +use Sub::Name(); BEGIN { # reinstall the carp()/croak() functions imported into SQL::Abstract @@ -12,21 +17,23 @@ 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/) { - __PACKAGE__->can($f)->(@_); - } - else { - $orig->(@_); - } - } + 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(@_); @@ -40,79 +47,80 @@ 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 select to make the final amount of columns equal the original one + my ($select) = $sql =~ /^ \s* SELECT \s+ (.+?) \s+ FROM/ix + or croak "Unrecognizable SELECT: $sql"; - 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 - }, - }); -} + # get the order_by only (or make up an order if none exists) + my $order_by = $self->_order_by( + (delete $order->{order_by}) || $self->_rno_default_order + ); -sub __strip_outer_paren { - my $sql = shift; + # whatever is left of the order_by + my $group_having = $self->_order_by($order); - if ($sql and not ref $sql) { - while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) { - $sql = $1; - } - } + my $qalias = $self->_quote ($self->{_dbic_rs_attrs}{alias}); + + $sql = sprintf (<_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_IN ($lhs, $op, $rhs); +# some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) ) +sub _rno_default_order { + return undef; } -sub _where_field_BETWEEN { - my ($self, $lhs, $op, $rhs) = @_; - $rhs = $self->_strip_outer_paren ($rhs); - return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs); -} +# Informix specific limit, almost like LIMIT/OFFSET +sub _SkipFirst { + my ($self, $sql, $order, $rows, $offset) = @_; -# Slow but ANSI standard Limit/Offset support. DB2 uses this -sub _RowNumberOver { - my ($self, $sql, $order, $rows, $offset ) = @_; + $sql =~ s/^ \s* SELECT \s+ //ix + or croak "Unrecognizable SELECT: $sql"; - $offset += 1; - my $last = $rows + $offset - 1; - my ( $order_by ) = $self->_order_by( $order ); + return sprintf ('SELECT %s%s%s%s', + $offset + ? sprintf ('SKIP %d ', $offset) + : '' + , + sprintf ('FIRST %d ', $rows), + $sql, + $self->_order_by ($order), + ); +} - $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 +# Firebird specific limit, reverse of _SkipFirst for Informix +sub _FirstSkip { + my ($self, $sql, $order, $rows, $offset) = @_; -SQL + $sql =~ s/^ \s* SELECT \s+ //ix + or croak "Unrecognizable SELECT: $sql"; - return $sql; + return sprintf ('SELECT %s%s%s%s', + sprintf ('FIRST %d ', $rows), + $offset + ? sprintf ('SKIP %d ', $offset) + : '' + , + $sql, + $self->_order_by ($order), + ); } -# Crappy Top based Limit/Offset support. MSSQL uses this currently, -# but may have to switch to RowNumberOver one day +# Crappy Top based Limit/Offset support. Legacy from MSSQL. sub _Top { my ( $self, $sql, $order, $rows, $offset ) = @_; @@ -134,8 +142,11 @@ sub _Top { } my $name_sep = $self->name_sep || '.'; - $name_sep = "\Q$name_sep\E"; - my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x; + 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); @@ -161,7 +172,8 @@ sub _Top { $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) ); } # column name seen more than once - alias it - elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) { + elsif ($orig_colname && + ($seen_names{$orig_colname} && $seen_names{$orig_colname} > 1) ) { $quoted_alias = $self->_quote ("${table}__${orig_colname}"); } @@ -210,14 +222,25 @@ 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}; + + # 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); # short circuit for counts - the ordering complexity is needless @@ -225,7 +248,6 @@ sub _Top { 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) { @@ -234,9 +256,10 @@ sub _Top { } } for my $col (keys %col_aliases) { - $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g; + $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g; } + my $inner_lim = $rows + $offset; $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner"; @@ -247,7 +270,7 @@ sub _Top { SELECT TOP $rows $outer_select FROM ( $sql - ) AS inner_sel + ) $quoted_rs_alias $order_by_outer SQL @@ -257,12 +280,13 @@ SQL $sql = <<"SQL"; SELECT $outer_select FROM - ( $sql ) AS outer_sel - $order_by_requested; + ( $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; } @@ -276,7 +300,7 @@ sub __record_alias { return unless $col; - # record unqialified name, undef (no adjustment) if a duplicate is found + # record unqualified name, undef (no adjustment) if a duplicate is found if (exists $register->{$col}) { $register->{$col} = undef; } @@ -300,17 +324,17 @@ 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) = @_; $self->{"${_}_bind"} = [] for (qw/having from order/); - if (ref $table eq 'SCALAR') { - $table = $$table; - } - elsif (not ref $table) { + 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]; @@ -326,32 +350,41 @@ 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; - $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" + my $sql = "INSERT INTO ${table} DEFAULT VALUES"; + + if (my $ret = ($_[1]||{})->{returning} ) { + $sql .= $self->_insert_returning ($ret); + } + + return $sql; } $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, @_); } @@ -377,28 +410,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 ( - '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}).' )'; + } + 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'), $self->_quote ($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' ) { @@ -416,9 +458,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}) { @@ -468,6 +509,14 @@ sub _table { } } +sub _generate_join_clause { + my ($self, $join_type) = @_; + + return sprintf ('%s JOIN ', + $join_type ? ' ' . uc($join_type) : '' + ); +} + sub _recurse_from { my ($self, $from, @join) = @_; my @sqlf; @@ -475,15 +524,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), ')'); @@ -544,34 +596,21 @@ sub _join_condition { } } -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}; } +# 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 @_; @@ -579,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 -