From: Matt S Trout Date: Mon, 7 Oct 2013 09:56:19 +0000 (+0000) Subject: import sqlmaker work from the dq branch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=10cef607fdaadada0fb9ceaa956ef2971a89940b;p=dbsrgits%2FDBIx-Class.git import sqlmaker work from the dq branch --- diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 0db6ef2..254febb 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -27,22 +27,50 @@ Currently the enhancements to L are: =item * Support of C<...FOR UPDATE> type of select statement modifiers +=item * The L operator + +=item * The L operator + =back =cut use base qw/ - DBIx::Class::SQLMaker::LimitDialects SQL::Abstract - DBIx::Class + DBIx::Class::SQLMaker::LimitDialects /; use mro 'c3'; +use Module::Runtime qw(use_module); use Sub::Name 'subname'; use DBIx::Class::Carp; +use DBIx::Class::Exception; +use Moo; use namespace::clean; -__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); +has limit_dialect => ( + is => 'rw', default => sub { 'LimitOffset' }, + trigger => sub { shift->clear_renderer_class } +); + +our %LIMIT_DIALECT_MAP = ( + 'GenericSubQ' => 'GenericSubquery', + 'RowCountOrGenericSubQ' => 'RowCountOrGenericSubquery', +); + +sub mapped_limit_dialect { + my ($self) = @_; + my $unmapped = $self->limit_dialect; + $LIMIT_DIALECT_MAP{$unmapped}||$unmapped; +} + +around _build_renderer_roles => sub { + my ($orig, $self) = (shift, shift); + return ( + $self->$orig(@_), + 'Data::Query::Renderer::SQL::Slice::'.$self->mapped_limit_dialect + ); +}; # for when I need a normalized l/r pair sub _quote_chars { @@ -52,6 +80,10 @@ sub _quote_chars { ; } +sub _build_converter_class { + Module::Runtime::use_module('DBIx::Class::SQLMaker::Converter') +} + # FIXME when we bring in the storage weaklink, check its schema # weaklink and channel through $schema->throw_exception sub throw_exception { DBIx::Class::Exception->throw($_[1]) } @@ -70,6 +102,9 @@ BEGIN { my($func) = (caller(1))[3]; __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_)); }; + + # Current SQLA pollutes its namespace - clean for the time being + namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/); } # the "oh noes offset/top without limit" constant @@ -85,10 +120,6 @@ BEGIN { # as the value to abuse with MSSQL ordered subqueries) sub __max_int () { 0x7FFFFFFF }; -# we ne longer need to check this - DBIC has ways of dealing with it -# specifically ::Storage::DBI::_resolve_bindattrs() -sub _assert_bindval_matches_bindtype () { 1 }; - # poor man's de-qualifier sub _quote { $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] ) @@ -109,9 +140,6 @@ sub _where_op_NEST { sub select { my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; - - $fields = $self->_recurse_fields($fields); - if (defined $offset) { $self->throw_exception('A supplied offset must be a non-negative integer') if ( $offset =~ /\D/ or $offset < 0 ); @@ -126,53 +154,66 @@ sub select { $limit = $self->__max_int; } + my %final_attrs = (%{$rs_attrs||{}}, limit => $limit, offset => $offset); + + if ($limit or $offset) { + my %slice_stability = $self->renderer->slice_stability; + + if (my $stability = $slice_stability{$offset ? 'offset' : 'limit'}) { + my $source = $rs_attrs->{_rsroot_rsrc}; + unless ( + $final_attrs{order_is_stable} + = $final_attrs{preserve_order} + = $source->schema->storage + ->_order_by_is_stable( + @final_attrs{qw(from order_by where)} + ) + ) { + if ($stability eq 'requires') { + if ($self->converter->_order_by_to_dq($final_attrs{order_by})) { + $self->throw_exception( + $self->limit_dialect.' limit/offset implementation requires a stable order for offset' + ); + } + if (my $ident_cols = $source->_identifying_column_set) { + $final_attrs{order_by} = [ + map "$final_attrs{alias}.$_", @$ident_cols + ]; + $final_attrs{order_is_stable} = 1; + } else { + $self->throw_exception(sprintf( + 'Unable to auto-construct stable order criteria for "skimming type" + limit ' + . "dialect based on source '%s'", $source->name) ); + } + } + } - my ($sql, @bind); - if ($limit) { - # this is legacy code-flow from SQLA::Limit, it is not set in stone - - ($sql, @bind) = $self->next::method ($table, $fields, $where); - - my $limiter; - - if( $limiter = $self->can ('emulate_limit') ) { - carp_unique( - 'Support for the legacy emulate_limit() mechanism inherited from ' - . 'SQL::Abstract::Limit has been deprecated, and will be removed when ' - . 'DBIC transitions to Data::Query. If your code uses this type of ' - . 'limit specification please file an RT and provide the source of ' - . 'your emulate_limit() implementation, so an acceptable upgrade-path ' - . 'can be devised' - ); } - else { - my $dialect = $self->limit_dialect - or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" ); - $limiter = $self->can ("_$dialect") - or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'"); + my %slice_subquery = $self->renderer->slice_subquery; + + if (my $subquery = $slice_subquery{$offset ? 'offset' : 'limit'}) { + $fields = [ map { + my $f = $fields->[$_]; + if (ref $f) { + $f = { '' => $f } unless ref($f) eq 'HASH'; + ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g; + } elsif ($f !~ /^\Q$final_attrs{alias}${\$self->name_sep}/) { + $f = { '' => $f }; + ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g; + } + $f; + } 0 .. $#$fields ]; } - - $sql = $self->$limiter ( - $sql, - { %{$rs_attrs||{}}, _selector_sql => $fields }, - $limit, - $offset - ); } - else { - ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs); - } - - push @{$self->{where_bind}}, @bind; -# this *must* be called, otherwise extra binds will remain in the sql-maker - my @all_bind = $self->_assemble_binds; + my ($sql, @bind) = $self->next::method ($table, $fields, $where, $final_attrs{order_by}, \%final_attrs ); $sql .= $self->_lock_select ($rs_attrs->{for}) if $rs_attrs->{for}; - return wantarray ? ($sql, @all_bind) : $sql; + return wantarray ? ($sql, @bind) : $sql; } sub _assemble_binds { @@ -192,333 +233,53 @@ sub _lock_select { $sql = "FOR $$type"; } else { - $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" ); + $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FO +R type '$type' requested" ); } return " $sql"; } -# Handle default inserts -sub insert { -# optimized due to hotttnesss -# my ($self, $table, $data, $options) = @_; - - # 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 @bind; - my $sql = sprintf( - 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1]) - ); - - if ( ($_[3]||{})->{returning} ) { - my $s; - ($s, @bind) = $_[0]->_insert_returning ($_[3]); - $sql .= $s; - } - - return ($sql, @bind); - } - - next::method(@_); +sub _recurse_from { + scalar shift->_render_sqla(table => \@_); } -sub _recurse_fields { - 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($_) } @$fields); - } - elsif ($ref eq 'HASH') { - my %hash = %$fields; # shallow copy - - my $as = delete $hash{-as}; # if supplied +1; - my ($func, $args, @toomany) = %hash; +=head1 OPERATORS - # there should be only one pair - if (@toomany) { - $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) ); - } +=head2 -ident - if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) { - $self->throw_exception ( - '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 }' - ); - } +Used to explicitly specify an SQL identifier. Takes a plain string as value +which is then invariably treated as a column name (and is being properly +quoted if quoting has been requested). Most useful for comparison of two +columns: - my $select = sprintf ('%s( %s )%s', - $self->_sqlcase($func), - $self->_recurse_fields($args), - $as - ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) - : '' + my %where = ( + priority => { '<', 2 }, + requestor => { -ident => 'submitter' } ); - return $select; - } - # Is the second check absolutely necessary? - elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { - push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields]; - return $$fields->[0]; - } - else { - $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} ); - } -} +which results in: + $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"'; + @bind = ('2'); -# 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 more 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) = @_; - - my $sql = ''; - - if ($arg->{group_by}) { - # horrible horrible, waiting for refactor - local $self->{select_bind}; - if (my $g = $self->_recurse_fields($arg->{group_by}) ) { - $sql .= $self->_sqlcase(' group by ') . $g; - push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]}; - } - } +=head2 -value - if (defined $arg->{having}) { - my ($frag, @bind) = $self->_recurse_where($arg->{having}); - push(@{$self->{having_bind}}, @bind); - $sql .= $self->_sqlcase(' having ') . $frag; - } +The -value operator signals that the argument to the right is a raw bind value. +It will be passed straight to DBI, without invoking any of the SQL::Abstract +condition-parsing logic. This allows you to, for example, pass an array as a +column value for databases that support array datatypes, e.g.: - if (defined $arg->{order_by}) { - $sql .= $self->_order_by ($arg->{order_by}); - } - - return $sql; -} - -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; - } -} - -sub _split_order_chunk { - my ($self, $chunk) = @_; - - # strip off sort modifiers, but always succeed, so $1 gets reset - $chunk =~ s/ (?: \s+ (ASC|DESC) )? \s* $//ix; - - return ( - $chunk, - ( $1 and uc($1) eq 'DESC' ) ? 1 : 0, - ); -} - -sub _table { -# 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]->_recurse_from($_[1]); - } - elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') { - my ($sql, @bind) = @{ ${$_[1]} }; - push @{$_[0]->{from_bind}}, @bind; - return $sql - } - } - return $_[0]->next::method ($_[1]); -} - -sub _generate_join_clause { - my ($self, $join_type) = @_; - - $join_type = $self->{_default_jointype} - if ! defined $join_type; - - return sprintf ('%s JOIN ', - $join_type ? $self->_sqlcase($join_type) : '' + my %where = ( + array => { -value => [1, 2, 3] } ); -} - -sub _recurse_from { - my $self = shift; - return join (' ', $self->_gen_from_blocks(@_) ); -} - -sub _gen_from_blocks { - my ($self, $from, @joins) = @_; - - my @fchunks = $self->_from_chunk_to_sql($from); - for (@joins) { - my ($to, $on) = @$_; +which results in: - # check whether a join type exists - my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; - 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; - } - - my @j = $self->_generate_join_clause( $join_type ); - - if (ref $to eq 'ARRAY') { - push(@j, '(', $self->_recurse_from(@$to), ')'); - } - else { - push(@j, $self->_from_chunk_to_sql($to)); - } - - my ($sql, @bind) = $self->_join_condition($on); - push(@j, ' ON ', $sql); - push @{$self->{from_bind}}, @bind; - - push @fchunks, join '', @j; - } - - return @fchunks; -} - -sub _from_chunk_to_sql { - my ($self, $fromspec) = @_; - - return join (' ', do { - if (! ref $fromspec) { - $self->_quote($fromspec); - } - elsif (ref $fromspec eq 'SCALAR') { - $$fromspec; - } - elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') { - push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec]; - $$fromspec->[0]; - } - elsif (ref $fromspec eq 'HASH') { - my ($as, $table, $toomuch) = ( map - { $_ => $fromspec->{$_} } - ( grep { $_ !~ /^\-/ } keys %$fromspec ) - ); - - $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" ) - if defined $toomuch; - - ($self->_from_chunk_to_sql($table), $self->_quote($as) ); - } - else { - $self->throw_exception('Unsupported from refkind: ' . ref $fromspec ); - } - }); -} - -sub _join_condition { - my ($self, $cond) = @_; - - # Backcompat for the old days when a plain hashref - # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2 - # Once things settle we should start warning here so that - # folks unroll their hacks - if ( - ref $cond eq 'HASH' - and - keys %$cond == 1 - and - (keys %$cond)[0] =~ /\./ - and - ! ref ( (values %$cond)[0] ) - ) { - $cond = { keys %$cond => { -ident => values %$cond } } - } - elsif ( ref $cond eq 'ARRAY' ) { - # do our own ORing so that the hashref-shim above is invoked - my @parts; - my @binds; - foreach my $c (@$cond) { - my ($sql, @bind) = $self->_join_condition($c); - push @binds, @bind; - push @parts, $sql; - } - return join(' OR ', @parts), @binds; - } - - return $self->_recurse_where($cond); -} - -# This is hideously ugly, but SQLA does not understand multicol IN expressions -# FIXME TEMPORARY - DQ should have native syntax for this -# moved here to raise API questions -# -# !!! EXPERIMENTAL API !!! WILL CHANGE !!! -sub _where_op_multicolumn_in { - my ($self, $lhs, $rhs) = @_; - - if (! ref $lhs or ref $lhs eq 'ARRAY') { - my (@sql, @bind); - for (ref $lhs ? @$lhs : $lhs) { - if (! ref $_) { - push @sql, $self->_quote($_); - } - elsif (ref $_ eq 'SCALAR') { - push @sql, $$_; - } - elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') { - my ($s, @b) = @$$_; - push @sql, $s; - push @bind, @b; - } - else { - $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs..."); - } - } - $lhs = \[ join(', ', @sql), @bind]; - } - elsif (ref $lhs eq 'SCALAR') { - $lhs = \[ $$lhs ]; - } - elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) { - # noop - } - else { - $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs..."); - } - - # is this proper...? - $rhs = \[ $self->_recurse_where($rhs) ]; - - for ($lhs, $rhs) { - $$_->[0] = "( $$_->[0] )" - unless $$_->[0] =~ /^ \s* \( .* \) \s* ^/xs; - } - - \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ]; -} - -1; + $stmt = 'WHERE array = ?'; + @bind = ([1, 2, 3]); =head1 AUTHORS diff --git a/lib/DBIx/Class/SQLMaker/ACCESS.pm b/lib/DBIx/Class/SQLMaker/ACCESS.pm index d8bfa2c..6d0726f 100644 --- a/lib/DBIx/Class/SQLMaker/ACCESS.pm +++ b/lib/DBIx/Class/SQLMaker/ACCESS.pm @@ -3,32 +3,11 @@ package # Hide from PAUSE use strict; use warnings; +use Module::Runtime (); use base 'DBIx::Class::SQLMaker'; -# inner joins must be prefixed with 'INNER ' -sub new { - my $class = shift; - my $self = $class->next::method(@_); - - $self->{_default_jointype} = 'INNER'; - - return $self; -} - -# MSAccess is retarded wrt multiple joins in FROM - it requires a certain -# way of parenthesizing each left part before each next right part -sub _recurse_from { - my @j = shift->_gen_from_blocks(@_); - - # first 2 steps need no parenthesis - my $fin_join = join (' ', splice @j, 0, 2); - - while (@j) { - $fin_join = sprintf '( %s ) %s', $fin_join, (shift @j); - } - - # the entire FROM is *ALSO* expected parenthesized - "( $fin_join )"; +sub _build_base_renderer_class { + Module::Runtime::use_module('DBIx::Class::SQLMaker::Renderer::Access'); } 1; diff --git a/lib/DBIx/Class/SQLMaker/Converter.pm b/lib/DBIx/Class/SQLMaker/Converter.pm new file mode 100644 index 0000000..d904a1f --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Converter.pm @@ -0,0 +1,262 @@ +package DBIx::Class::SQLMaker::Converter; + +use Data::Query::Constants qw(DQ_ALIAS DQ_GROUP DQ_WHERE DQ_JOIN DQ_SLICE); +use Moo; +use namespace::clean; + +extends 'SQL::Abstract::Converter'; + +around _select_to_dq => sub { + my ($orig, $self) = (shift, shift); + my $attrs = $_[4]; + my $orig_dq = $self->$orig(@_); + return $orig_dq unless $attrs->{limit}; + +{ + type => DQ_SLICE, + from => $orig_dq, + limit => do { + local $SQL::Abstract::Converter::Cur_Col_Meta + = { sqlt_datatype => 'integer' }; + $self->_value_to_dq($attrs->{limit}) + }, + ($attrs->{offset} + ? (offset => do { + local $SQL::Abstract::Converter::Cur_Col_Meta + = { sqlt_datatype => 'integer' }; + $self->_value_to_dq($attrs->{offset}) + }) + : () + ), + ($attrs->{order_is_stable} + ? (order_is_stable => 1) + : ()), + ($attrs->{preserve_order} + ? (preserve_order => 1) + : ()) + }; +}; + +around _select_field_to_dq => sub { + my ($orig, $self) = (shift, shift); + my ($field) = @_; + my $ref = ref $field; + if ($ref eq 'HASH') { + my %hash = %$field; # shallow copy + + my $as = delete $hash{-as}; # if supplied + + my ($func, $args, @toomany) = %hash; + + # there should be only one pair + if (@toomany) { + die( "Malformed select argument - too many keys in hash: " . join (',', keys %$field ) ); + } + + if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) { + die( + '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 $field_dq = do { + if ($func) { + $self->_op_to_dq( + apply => $self->_ident_to_dq(uc($func)), + @{$self->_select_field_list_to_dq($args)}, + ); + } else { + $self->_select_field_to_dq($args); + } + }; + + return $field_dq unless $as; + + return +{ + type => DQ_ALIAS, + from => $field_dq, + to => $as + }; + } else { + return $self->$orig(@_); + } +}; + +around _source_to_dq => sub { + my ($orig, $self) = (shift, shift); + my $attrs = $_[4]; # table, fields, where, order, attrs + my $start_dq = $self->$orig(@_); + # if we have HAVING but no GROUP BY we render an empty DQ_GROUP + # node, which causes DQ to recognise the HAVING as being what it is. + # This ... is kinda bull. But that's how HAVING is specified. + return $start_dq unless $attrs->{group_by} or $attrs->{having}; + my $grouped_dq = $self->_group_by_to_dq($attrs->{group_by}||[], $start_dq); + return $grouped_dq unless $attrs->{having}; + +{ + type => DQ_WHERE, + from => $grouped_dq, + where => $self->_where_to_dq($attrs->{having}) + }; +}; + +sub _group_by_to_dq { + my ($self, $group, $from) = @_; + +{ + type => DQ_GROUP, + by => $self->_select_field_list_to_dq($group), + from => $from, + }; +} + +around _table_to_dq => sub { + my ($orig, $self) = (shift, shift); + my ($spec) = @_; + if (my $ref = ref $spec ) { + if ($ref eq 'ARRAY') { + return $self->_join_to_dq(@$spec); + } + elsif ($ref eq 'HASH') { + my ($as, $table, $toomuch) = ( map + { $_ => $spec->{$_} } + ( grep { $_ !~ /^\-/ } keys %$spec ) + ); + die "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" + if defined $toomuch; + + return +{ + type => DQ_ALIAS, + from => $self->_table_to_dq($table), + to => $as, + ($spec->{-rsrc} + ? ( + 'dbix-class.source_name' => $spec->{-rsrc}->source_name, + 'dbix-class.join_path' => $spec->{-join_path}, + 'dbix-class.is_single' => $spec->{-is_single}, + ) + : () + ) + }; + } + } + return $self->$orig(@_); +}; + +sub _join_to_dq { + my ($self, $from, @joins) = @_; + + my $cur_dq = $self->_table_to_dq($from); + + if (!@joins or @joins == 1 and ref($joins[0]) eq 'HASH') { + return $cur_dq; + } + + foreach my $join (@joins) { + my ($to, $on) = @$join; + + # check whether a join type exists + my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; + my $join_type; + if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) { + $join_type = lc($to_jt->{-join_type}); + $join_type =~ s/^\s+ | \s+$//xg; + undef($join_type) unless $join_type =~ s/^(left|right).*/$1/; + } + + $cur_dq = +{ + type => DQ_JOIN, + ($join_type ? (outer => $join_type) : ()), + left => $cur_dq, + right => $self->_table_to_dq($to), + ($on + ? (on => $self->_expr_to_dq($self->_expand_join_condition($on))) + : ()), + }; + } + + return $cur_dq; +} + +sub _expand_join_condition { + my ($self, $cond) = @_; + + # Backcompat for the old days when a plain hashref + # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2 + # Once things settle we should start warning here so that + # folks unroll their hacks + if ( + ref $cond eq 'HASH' + and + keys %$cond == 1 + and + (keys %$cond)[0] =~ /\./ + and + ! ref ( (values %$cond)[0] ) + ) { + return +{ keys %$cond => { -ident => values %$cond } } + } + elsif ( ref $cond eq 'ARRAY' ) { + return [ map $self->_expand_join_condition($_), @$cond ]; + } + + return $cond; +} + +around _bind_to_dq => sub { + my ($orig, $self) = (shift, shift); + my @args = do { + if ($self->bind_meta) { + map { ref($_) eq 'ARRAY' ? $_ : [ {} => $_ ] } @_ + } else { + @_ + } + }; + return $self->$orig(@args); +}; + +1; + +=head1 OPERATORS + +=head2 -ident + +Used to explicitly specify an SQL identifier. Takes a plain string as value +which is then invariably treated as a column name (and is being properly +quoted if quoting has been requested). Most useful for comparison of two +columns: + + my %where = ( + priority => { '<', 2 }, + requestor => { -ident => 'submitter' } + ); + +which results in: + + $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"'; + @bind = ('2'); + +=head2 -value + +The -value operator signals that the argument to the right is a raw bind value. +It will be passed straight to DBI, without invoking any of the SQL::Abstract +condition-parsing logic. This allows you to, for example, pass an array as a +column value for databases that support array datatypes, e.g.: + + my %where = ( + array => { -value => [1, 2, 3] } + ); + +which results in: + + $stmt = 'WHERE array = ?'; + @bind = ([1, 2, 3]); + +=head1 AUTHORS + +See L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut diff --git a/lib/DBIx/Class/SQLMaker/Converter/Oracle.pm b/lib/DBIx/Class/SQLMaker/Converter/Oracle.pm new file mode 100644 index 0000000..f3791ca --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Converter/Oracle.pm @@ -0,0 +1,57 @@ +package DBIx::Class::SQLMaker::Converter::Oracle; + +use Data::Query::ExprHelpers; +use Moo; +use namespace::clean; + +extends 'DBIx::Class::SQLMaker::Converter'; + +around _where_hashpair_to_dq => sub { + my ($orig, $self) = (shift, shift); + my ($k, $v, $logic) = @_; + if (ref($v) eq 'HASH' and (keys %$v == 1) and lc((keys %$v)[0]) eq '-prior') { + my $rhs = $self->_expr_to_dq((values %$v)[0]); + return $self->_op_to_dq( + $self->{cmp}, $self->_ident_to_dq($k), $self->_op_to_dq(PRIOR => $rhs) + ); + } else { + return $self->$orig(@_); + } +}; + +around _apply_to_dq => sub { + my ($orig, $self) = (shift, shift); + my ($op, $v) = @_; + if ($op eq 'PRIOR') { + return $self->_op_to_dq(PRIOR => $self->_expr_to_dq($v)); + } else { + return $self->$orig(@_); + } +}; + +around _insert_to_dq => sub { + my ($orig, $self) = (shift, shift); + my (undef, undef, $options) = @_; + my $dq = $self->$orig(@_); + my $ret_count = @{$dq->{returning}}; + @{$options->{returning_container}} = (undef) x $ret_count; + my $into = [ + map { + my $r_dq = $dq->{returning}[$_]; + no warnings 'once'; +::Dwarn($r_dq); + local $SQL::Abstract::Converter::Cur_Col_Meta = ( + is_Identifier($r_dq) + ? join('.', @{$r_dq->{elements}}) + : ((is_Literal($r_dq) and !ref($r_dq->{literal}) + and $r_dq->{literal} =~ /^\w+$/) + ? $r_dq->{literal} + : undef) + ); + $self->_value_to_dq(\($options->{returning_container}[$_])); + } 0..$ret_count-1 + ]; + +{ %$dq, 'Data::Query::Renderer::SQL::Dialect::ReturnInto.into' => $into }; +}; + +1; diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index ec9300a..d3ea35c 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -358,10 +358,9 @@ sub _prep_for_skimming_limit { for my $ch ($self->_order_by_chunks ($inner_order)) { $ch = $ch->[0] if ref $ch eq 'ARRAY'; - ($ch, my $is_desc) = $self->_split_order_chunk($ch); - - # !NOTE! outside chunks come in reverse order ( !$is_desc ) - push @out_chunks, { ($is_desc ? '-asc' : '-desc') => \$ch }; + $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix; + my $dir = uc ($1||'ASC'); + push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' ); } $sq_attrs->{order_by_middle} = $self->_order_by (\@out_chunks); @@ -384,6 +383,18 @@ sub _prep_for_skimming_limit { # Whatever order bindvals there are, they will be realiased and # reselected, and need to show up at end of the initial inner select push @{$self->{select_bind}}, @{$self->{order_bind}}; + + # if this is a part of something bigger, we need to add back all + # the extra order_by's, as they may be relied upon by the outside + # of a prefetch or something + if ($rs_attrs->{_is_internal_subuery}) { + $sq_attrs->{selection_outer} .= sprintf ", $extra_order_sel->{$_} AS $_" + for sort + { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } + grep { $_ !~ /[^\w\-]/ } # ignore functions + keys %$extra_order_sel + ; + } } # and this is order re-alias magic @@ -507,6 +518,32 @@ sub _FetchFirst { return $sql; } +=head2 RowCountOrGenericSubQ + +This is not exactly a limit dialect, but more of a proxy for B. +If no $offset is supplied the limit is simply performed as: + + SET ROWCOUNT $limit + SELECT ... + SET ROWCOUNT 0 + +Otherwise we fall back to L + +=cut + +sub _RowCountOrGenericSubQ { + my $self = shift; + my ($sql, $rs_attrs, $rows, $offset) = @_; + + return $self->_GenericSubQ(@_) if $offset; + + return sprintf <<"EOF", $rows, $sql, $self->_parse_rs_attrs( $rs_attrs ); +SET ROWCOUNT %d +%s %s +SET ROWCOUNT 0 +EOF +} + =head2 GenericSubQ SELECT * FROM ( @@ -533,106 +570,59 @@ sub _GenericSubQ { my ($self, $sql, $rs_attrs, $rows, $offset) = @_; my $root_rsrc = $rs_attrs->{_rsroot_rsrc}; + my $root_tbl_name = $root_rsrc->name; - # Explicitly require an order_by - # GenSubQ is slow enough as it is, just emulating things - # like in other cases is not wise - make the user work - # to shoot their DBA in the foot - my $supplied_order = delete $rs_attrs->{order_by} or $self->throw_exception ( - 'Generic Subquery Limit does not work on resultsets without an order. Provide a stable, ' - . 'root-table-based order criteria.' - ); - - my $usable_order_ci = $root_rsrc->storage->_main_source_order_by_portion_is_stable( - $root_rsrc, - $supplied_order, - $rs_attrs->{where}, - ) or $self->throw_exception( - 'Generic Subquery Limit can not work with order criteria based on sources other than the current one' - ); - -### -### -### we need to know the directions after we figured out the above - reextract *again* -### this is eyebleed - trying to get it to work at first - my @order_bits = do { + my ($first_order_by) = do { local $self->{quote_char}; local $self->{order_bind}; - map { ref $_ ? $_->[0] : $_ } $self->_order_by_chunks ($supplied_order) - }; + map { ref $_ ? $_->[0] : $_ } $self->_order_by_chunks ($rs_attrs->{order_by}) + } or $self->throw_exception ( + 'Generic Subquery Limit does not work on resultsets without an order. Provide a single, ' + . 'unique-column order criteria.' + ); - # truncate to what we'll use - $#order_bits = ( (keys %$usable_order_ci) - 1 ); + $first_order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix; + my $direction = lc ($1 || 'asc'); - # @order_bits likely will come back quoted (due to how the prefetch - # rewriter operates - # Hence supplement the column_info lookup table with quoted versions - if ($self->quote_char) { - $usable_order_ci->{$self->_quote($_)} = $usable_order_ci->{$_} - for keys %$usable_order_ci; - } + my ($first_ord_alias, $first_ord_col) = $first_order_by =~ /^ (?: ([^\.]+) \. )? ([^\.]+) $/x; -# calculate the condition - my $count_tbl_alias = 'rownum__emulation'; - my $root_alias = $rs_attrs->{alias}; - my $root_tbl_name = $root_rsrc->name; - - my (@unqualified_names, @qualified_names, @is_desc, @new_order_by); + $self->throw_exception(sprintf + "Generic Subquery Limit order criteria can be only based on the root-source '%s'" + . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias}, + ) if ($first_ord_alias and $first_ord_alias ne $rs_attrs->{alias}); - for my $bit (@order_bits) { + $first_ord_alias ||= $rs_attrs->{alias}; - ($bit, my $is_desc) = $self->_split_order_chunk($bit); + $self->throw_exception( + "Generic Subquery Limit first order criteria '$first_ord_col' must be unique" + ) unless $root_rsrc->_identifying_column_set([$first_ord_col]); + + my $sq_attrs = do { + # perform the mangling only using the very first order crietria + # (the one we care about) + local $rs_attrs->{order_by} = $first_order_by; + $self->_subqueried_limit_attrs ($sql, $rs_attrs); + }; - push @is_desc, $is_desc; - push @unqualified_names, $usable_order_ci->{$bit}{-colname}; - push @qualified_names, $usable_order_ci->{$bit}{-fq_colname}; + my $cmp_op = $direction eq 'desc' ? '>' : '<'; + my $count_tbl_alias = 'rownum__emulation'; - push @new_order_by, { ($is_desc ? '-desc' : '-asc') => $usable_order_ci->{$bit}{-fq_colname} }; + my ($order_sql, @order_bind) = do { + local $self->{order_bind}; + my $s = $self->_order_by (delete $rs_attrs->{order_by}); + ($s, @{$self->{order_bind}}); }; + my $group_having_sql = $self->_parse_rs_attrs($rs_attrs); - my (@where_cond, @skip_colpair_stack); - for my $i (0 .. $#order_bits) { - my $ci = $usable_order_ci->{$order_bits[$i]}; - - my ($subq_col, $main_col) = map { "$_.$ci->{-colname}" } ($count_tbl_alias, $root_alias); - my $cur_cond = { $subq_col => { ($is_desc[$i] ? '>' : '<') => { -ident => $main_col } } }; - - push @skip_colpair_stack, [ - { $main_col => { -ident => $subq_col } }, - ]; - - # we can trust the nullability flag because - # we already used it during _id_col_set resolution - # - if ($ci->{is_nullable}) { - push @{$skip_colpair_stack[-1]}, { $main_col => undef, $subq_col=> undef }; - - $cur_cond = [ - { - ($is_desc[$i] ? $subq_col : $main_col) => { '!=', undef }, - ($is_desc[$i] ? $main_col : $subq_col) => undef, - }, - { - $subq_col => { '!=', undef }, - $main_col => { '!=', undef }, - -and => $cur_cond, - }, - ]; - } - - push @where_cond, { '-and', => [ @skip_colpair_stack[0..$i-1], $cur_cond ] }; - } + my $in_sel = $sq_attrs->{selection_inner}; -# reuse the sqlmaker WHERE, this will not be returning binds - my $counted_where = do { - local $self->{where_bind}; - $self->where(\@where_cond); - }; + # add the order supplement (if any) as this is what will be used for the outer WHERE + $in_sel .= ", $_" for keys %{$sq_attrs->{order_supplement}}; -# construct the rownum condition by hand my $rownum_cond; if ($offset) { $rownum_cond = 'BETWEEN ? AND ?'; + push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ], [ $self->__total_bindtype => $offset + $rows - 1] @@ -640,51 +630,30 @@ sub _GenericSubQ { } else { $rownum_cond = '< ?'; + push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ] ; } -# and what we will order by inside - my $inner_order_sql = do { - local $self->{order_bind}; - - my $s = $self->_order_by (\@new_order_by); - - $self->throw_exception('Inner gensubq order may not contain binds... something went wrong') - if @{$self->{order_bind}}; - - $s; - }; - -### resume originally scheduled programming -### -### - - # we need to supply the order for the supplements to be properly calculated - my $sq_attrs = $self->_subqueried_limit_attrs ( - $sql, { %$rs_attrs, order_by => \@new_order_by } - ); - - my $in_sel = $sq_attrs->{selection_inner}; - - # add the order supplement (if any) as this is what will be used for the outer WHERE - $in_sel .= ", $_" for sort keys %{$sq_attrs->{order_supplement}}; - - my $group_having_sql = $self->_parse_rs_attrs($rs_attrs); - + # even though binds in order_by make no sense here (the rs needs to be + # ordered by a unique column first) - pass whatever there may be through + # anyway + push @{$self->{limit_bind}}, @order_bind; return sprintf (" SELECT $sq_attrs->{selection_outer} FROM ( SELECT $in_sel $sq_attrs->{query_leftover}${group_having_sql} ) %s -WHERE ( SELECT COUNT(*) FROM %s %s $counted_where ) $rownum_cond -$inner_order_sql +WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) $rownum_cond +$order_sql ", map { $self->_quote ($_) } ( $rs_attrs->{alias}, $root_tbl_name, $count_tbl_alias, + "$count_tbl_alias.$first_ord_col", + "$first_ord_alias.$first_ord_col", )); } @@ -799,7 +768,7 @@ sub _subqueried_limit_attrs { for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) { # order with bind $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY'; - ($chunk) = $self->_split_order_chunk($chunk); + $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix; next if $in_sel_index->{$chunk}; diff --git a/lib/DBIx/Class/SQLMaker/MSSQL.pm b/lib/DBIx/Class/SQLMaker/MSSQL.pm index 39e2c4f..f64d972 100644 --- a/lib/DBIx/Class/SQLMaker/MSSQL.pm +++ b/lib/DBIx/Class/SQLMaker/MSSQL.pm @@ -1,9 +1,6 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::MSSQL; -use warnings; -use strict; - use base qw( DBIx::Class::SQLMaker ); # diff --git a/lib/DBIx/Class/SQLMaker/MySQL.pm b/lib/DBIx/Class/SQLMaker/MySQL.pm index 34ee054..1b16ca8 100644 --- a/lib/DBIx/Class/SQLMaker/MySQL.pm +++ b/lib/DBIx/Class/SQLMaker/MySQL.pm @@ -1,24 +1,10 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::MySQL; -use warnings; -use strict; - use base qw( DBIx::Class::SQLMaker ); -# -# MySQL does not understand the standard INSERT INTO $table DEFAULT VALUES -# Adjust SQL here instead -# -sub insert { - my $self = shift; - - if (! $_[1] or (ref $_[1] eq 'HASH' and !keys %{$_[1]} ) ) { - my $table = $self->_quote($_[0]); - return "INSERT INTO ${table} () VALUES ()" - } - - return $self->next::method (@_); +sub _build_base_renderer_class { + Module::Runtime::use_module('Data::Query::Renderer::SQL::MySQL'); } # Allow STRAIGHT_JOIN's @@ -32,71 +18,6 @@ sub _generate_join_clause { return $self->next::method($join_type); } -my $force_double_subq; -$force_double_subq = sub { - my ($self, $sql) = @_; - - require Text::Balanced; - my $new_sql; - while (1) { - - my ($prefix, $parenthesized); - - ($parenthesized, $sql, $prefix) = do { - # idiotic design - writes to $@ but *DOES NOT* throw exceptions - local $@; - Text::Balanced::extract_bracketed( $sql, '()', qr/[^\(]*/ ); - }; - - # this is how an error is indicated, in addition to crapping in $@ - last unless $parenthesized; - - if ($parenthesized =~ $self->{_modification_target_referenced_re}) { - # is this a select subquery? - if ( $parenthesized =~ /^ \( \s* SELECT \s+ /xi ) { - $parenthesized = "( SELECT * FROM $parenthesized `_forced_double_subquery` )"; - } - # then drill down until we find it (if at all) - else { - $parenthesized =~ s/^ \( (.+) \) $/$1/x; - $parenthesized = join ' ', '(', $self->$force_double_subq( $parenthesized ), ')'; - } - } - - $new_sql .= $prefix . $parenthesized; - } - - return $new_sql . $sql; -}; - -sub update { - my $self = shift; - - # short-circuit unless understood identifier - return $self->next::method(@_) unless $self->{_modification_target_referenced_re}; - - my ($sql, @bind) = $self->next::method(@_); - - $sql = $self->$force_double_subq($sql) - if $sql =~ $self->{_modification_target_referenced_re}; - - return ($sql, @bind); -} - -sub delete { - my $self = shift; - - # short-circuit unless understood identifier - return $self->next::method(@_) unless $self->{_modification_target_referenced_re}; - - my ($sql, @bind) = $self->next::method(@_); - - $sql = $self->$force_double_subq($sql) - if $sql =~ $self->{_modification_target_referenced_re}; - - return ($sql, @bind); -} - # LOCK IN SHARE MODE my $for_syntax = { update => 'FOR UPDATE', diff --git a/lib/DBIx/Class/SQLMaker/Oracle.pm b/lib/DBIx/Class/SQLMaker/Oracle.pm index d1ed9a2..abbba71 100644 --- a/lib/DBIx/Class/SQLMaker/Oracle.pm +++ b/lib/DBIx/Class/SQLMaker/Oracle.pm @@ -1,10 +1,11 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::Oracle; -use warnings; -use strict; +use Module::Runtime (); +use Moo; +use namespace::clean; -use base qw( DBIx::Class::SQLMaker ); +extends 'DBIx::Class::SQLMaker'; BEGIN { use DBIx::Class::Optional::Dependencies; @@ -12,17 +13,19 @@ BEGIN { unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); } -sub new { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; - push @{$opts{special_ops}}, { - regex => qr/^prior$/i, - handler => '_where_field_PRIOR', - }; - - $self->next::method(\%opts); +sub _build_converter_class { + Module::Runtime::use_module('DBIx::Class::SQLMaker::Converter::Oracle'); } +around _build_renderer_roles => sub { + my ($orig, $self) = (shift, shift); + ( + 'Data::Query::Renderer::SQL::Extension::ConnectBy', + 'Data::Query::Renderer::SQL::Dialect::ReturnInto', + $self->$orig(@_), + ); +}; + sub _assemble_binds { my $self = shift; return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where oracle_connect_by group having order limit/); @@ -92,7 +95,7 @@ sub _order_siblings_by { return wantarray ? ( $sql, @bind ) : $sql; } -# we need to add a '=' only when PRIOR is used against a column directly +# we need to add a '=' only when PRIOR is used against a column diretly # i.e. when it is invoked by a special_op callback sub _where_field_PRIOR { my ($self, $lhs, $op, $rhs) = @_; @@ -177,7 +180,7 @@ sub _shorten_identifier { } } - # still too long - just start cutting proportionally + # still too long - just start cuting proportionally if ($concat_len > $max_trunc) { my $trim_ratio = $max_trunc / $concat_len; diff --git a/lib/DBIx/Class/SQLMaker/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/OracleJoins.pm index b95c56e..e645382 100644 --- a/lib/DBIx/Class/SQLMaker/OracleJoins.pm +++ b/lib/DBIx/Class/SQLMaker/OracleJoins.pm @@ -2,94 +2,12 @@ package DBIx::Class::SQLMaker::OracleJoins; use warnings; use strict; +use Module::Runtime (); use base qw( DBIx::Class::SQLMaker::Oracle ); -sub select { - my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_; - - # pull out all join conds as regular WHEREs from all extra tables - if (ref($table) eq 'ARRAY') { - $where = $self->_oracle_joins($where, @{ $table }[ 1 .. $#$table ]); - } - - return $self->next::method($table, $fields, $where, $rs_attrs, @rest); -} - -sub _recurse_from { - my ($self, $from, @join) = @_; - - my @sqlf = $self->_from_chunk_to_sql($from); - - for (@join) { - my ($to, $on) = @$_; - - if (ref $to eq 'ARRAY') { - push (@sqlf, $self->_recurse_from(@{ $to })); - } - else { - push (@sqlf, $self->_from_chunk_to_sql($to)); - } - } - - return join q{, }, @sqlf; -} - -sub _oracle_joins { - my ($self, $where, @join) = @_; - my $join_where = $self->_recurse_oracle_joins(@join); - - if (keys %$join_where) { - if (!defined($where)) { - $where = $join_where; - } else { - if (ref($where) eq 'ARRAY') { - $where = { -or => $where }; - } - $where = { -and => [ $join_where, $where ] }; - } - } - return $where; -} - -sub _recurse_oracle_joins { - my $self = shift; - - my @where; - for my $j (@_) { - my ($to, $on) = @{ $j }; - - push @where, $self->_recurse_oracle_joins(@{ $to }) - if (ref $to eq 'ARRAY'); - - my $join_opts = ref $to eq 'ARRAY' ? $to->[0] : $to; - my $left_join = q{}; - my $right_join = q{}; - - if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) { - #TODO: Support full outer joins -- this would happen much earlier in - #the sequence since oracle 8's full outer join syntax is best - #described as INSANE. - $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n") - if $jt =~ /full/i; - - $left_join = q{(+)} if $jt =~ /left/i - && $jt !~ /inner/i; - - $right_join = q{(+)} if $jt =~ /right/i - && $jt !~ /inner/i; - } - - # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops - push @where, map { \sprintf ('%s%s = %s%s', - ref $_ ? $self->_recurse_where($_) : $self->_quote($_), - $left_join, - ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}), - $right_join, - )} keys %$on; - } - - return { -and => \@where }; +sub _build_base_renderer_class { + Module::Runtime::use_module('DBIx::Class::SQLMaker::Renderer::OracleJoins'); } 1; diff --git a/lib/DBIx/Class/SQLMaker/Renderer/Access.pm b/lib/DBIx/Class/SQLMaker/Renderer/Access.pm new file mode 100644 index 0000000..c54db8a --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Renderer/Access.pm @@ -0,0 +1,15 @@ +package DBIx::Class::SQLMaker::Renderer::Access; + +use Moo; +use namespace::clean; + +extends 'Data::Query::Renderer::SQL::Naive'; + +around _render_join => sub { + my ($orig, $self) = (shift, shift); + my ($dq) = @_; + local $dq->{outer} = 'INNER' if $dq->{on} and !$dq->{outer}; + [ '(', @{$self->$orig(@_)}, ')' ]; +}; + +1; diff --git a/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm new file mode 100644 index 0000000..ba512ce --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm @@ -0,0 +1,105 @@ +package DBIx::Class::SQLMaker::Renderer::OracleJoins; + +sub map_descending (&;@) { + my ($block, $in) = @_; + local $_ = $in; + $_ = $block->($_) if ref($_) eq 'HASH'; +#::Dwarn([mapped => $_]); + if (ref($_) eq 'REF' and ref($$_) eq 'HASH') { + $$_; + } elsif (ref($_) eq 'HASH') { +#::Dwarn([unmapped => $_]); +#::Dwarn([mapped => $mapped]); + my $mapped = $_; + local $_; + +{ map +($_ => &map_descending($block, $mapped->{$_})), keys %$mapped }; + } elsif (ref($_) eq 'ARRAY') { + [ map &map_descending($block, $_), @$_ ] + } else { + $_ + } +} + +use Data::Query::ExprHelpers; +use Moo; +use namespace::clean; + +extends 'Data::Query::Renderer::SQL::Naive'; + +around render => sub { + my ($orig, $self) = (shift, shift); + $self->$orig($self->_oracle_joins_unroll(@_)); +}; + +sub _oracle_joins_unroll { + my ($self, $dq) = @_; + map_descending { +#warn "here"; +#::Dwarn([unroll => $_]); + return $_ unless is_Join; + return \$self->_oracle_joins_mangle_join($_); + } $dq; +} + +sub _oracle_joins_mangle_join { + my ($self, $dq) = @_; + my ($mangled, $where) = $self->_oracle_joins_recurse_join($dq); + Where( + (@$where > 1 + ? Operator({ 'SQL.Naive' => 'and' }, $where) + : $where->[0]), + $mangled + ); +} + +sub _oracle_joins_recurse_join { + my ($self, $dq) = @_; + die "Can't handle cross join" unless $dq->{on}; + my $mangled = { %$dq }; + delete $mangled->{on}; + my @where; + my %idents; + foreach my $side (qw(left right)) { + if (is_Join $dq->{$side}) { + ($mangled->{$side}, my ($side_where, $side_idents)) + = $self->_oracle_joins_recurse_join($dq->{$side}); + push @where, $side_where; + $idents{$side} = $side_idents; + } else { + if (is_Identifier($dq->{$side})) { + $idents{$side} = { join($;, @{$dq->{$side}{elements}}) => 1 }; + } elsif (is_Alias($dq->{$side})) { + $idents{$side} = { $dq->{$side}{to} => 1 }; + } + $mangled->{$side} = $self->_oracle_joins_unroll($dq->{$side}); + } + } + my %other = (left => 'right', right => 'left'); + unshift @where, ( + $dq->{outer} + ? map_descending { + return $_ + if is_Operator and ($_->{operator}{'SQL.Naive'}||'') eq '(+)'; + return $_ unless is_Identifier; + die "Can't unroll single part identifiers in on" + unless @{$_->{elements}} > 1; + my $check = join($;, @{$_->{elements}}[0..($#{$_->{elements}}-1)]); + if ($idents{$other{$dq->{outer}}}{$check}) { + return \Operator({ 'SQL.Naive' => '(+)' }, [ $_ ]); + } + return $_; + } $dq->{on} + : $dq->{on} + ); + return ($mangled, \@where, { map %{$_||{}}, @idents{qw(left right)} }); +} + +around _default_simple_ops => sub { + my ($orig, $self) = (shift, shift); + +{ + %{$self->$orig(@_)}, + '(+)' => 'unop_reverse', + }; +}; + +1; diff --git a/lib/DBIx/Class/SQLMaker/SQLite.pm b/lib/DBIx/Class/SQLMaker/SQLite.pm index 91f78e4..cf4b8fa 100644 --- a/lib/DBIx/Class/SQLMaker/SQLite.pm +++ b/lib/DBIx/Class/SQLMaker/SQLite.pm @@ -1,14 +1,15 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::SQLite; -use warnings; -use strict; - use base qw( DBIx::Class::SQLMaker ); +#sub _build_renderer_class { +# Module::Runtime::use_module('Data::Query::Renderer::SQL::SQLite') +#} + # # SQLite does not understand SELECT ... FOR UPDATE # Disable it here -sub _lock_select () { '' }; +sub _lock_select { '' }; 1; diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 4c54e2c..c84701d 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -16,6 +16,7 @@ use mro 'c3'; use List::Util 'first'; use Scalar::Util 'blessed'; use Sub::Name 'subname'; +use Data::Query::ExprHelpers; use namespace::clean; # @@ -784,6 +785,18 @@ sub _inner_join_to_node { sub _extract_order_criteria { my ($self, $order_by, $sql_maker) = @_; + $sql_maker ||= $self->sql_maker; + + my $order_dq = $sql_maker->converter->_order_by_to_dq($order_by); + + my @by; + while (is_Literal($order_dq)) { + push @by, $order_dq->{by}; + $order_dq = $order_dq->{from}; + } + + return map { [ $sql_maker->_render_dq($_) ] } @by; + my $parser = sub { my ($sql_maker, $order_by, $orig_quote_chars) = @_;