X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks.pm;h=429be4feee8c93a2e0e233f85e75dcaa54186ad0;hb=d3fdc7b81278f9ae2dad417d68815933f65842dd;hp=c98cfdb8014ef71562fecaddc1dcd9061b204161;hpb=9c1ffdde49834a40f61a8e1e4ebab4c77a5c10ce;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index c98cfdb..429be4f 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; @@ -28,6 +32,9 @@ BEGIN { } } + +# Tries to determine limit dialect. +# sub new { my $self = shift->SUPER::new(@_); @@ -41,54 +48,6 @@ 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 - -sub _strip_outer_paren { - my ($self, $arg) = @_; - - 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; - - if ($sql and not ref $sql) { - while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) { - $sql = $1; - } - } - - 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); -} - # Slow but ANSI standard Limit/Offset support. DB2 uses this sub _RowNumberOver { my ($self, $sql, $order, $rows, $offset ) = @_; @@ -165,7 +124,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}"); } @@ -316,17 +276,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]; @@ -342,10 +302,11 @@ 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, @@ -357,17 +318,19 @@ sub insert { $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, @_); } @@ -396,35 +359,33 @@ sub _recurse_fields { } 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 }' - ); - } - $select = sprintf ('%s( %s )', - $self->_sqlcase($func), - $self->_recurse_fields($args) + 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 ); } - $select .= " AS $as" if $as; return $select; } # Is the second check absolutely necessary? @@ -501,15 +462,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), ')'); @@ -573,6 +540,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"){ @@ -592,12 +560,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 @_; @@ -605,50 +576,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 -