X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FQ-Branch.git;a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=dda7fc5b89c46e945a1a8a9140aefd434f9a98b4;hp=35fbf0cf83c57cd950d13c261b965a0e43cc76f7;hb=6bbe13e99769ef04d6cda7a4a6ac6968b535435f;hpb=981d354553abe4f68e7a99f6702871bb2678613c diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 35fbf0c..dda7fc5 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -144,6 +144,7 @@ our %Defaults = ( op => '_expand_op', func => '_expand_func', values => '_expand_values', + list => '_expand_list', }, expand_op => { (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')), @@ -278,6 +279,20 @@ sub new { [ $_[0]->_order_by($_[2]) ]; }; } + if (__PACKAGE__->can('_select_fields') ne $class->can('_select_fields')) { + $opt{expand_clause}{'select.select'} = sub { $_[2] }; + $opt{render_clause}{'select.select'} = sub { + my @super = $_[0]->_select_fields($_[2]); + my $effort = [ + ref($super[0]) eq 'HASH' + ? $_[0]->render_expr($super[0]) + : @super + ]; + return $_[0]->join_query_parts( + ' ', { -keyword => 'select' }, $effort + ); + }; + } if ($class->isa('DBIx::Class::SQLMaker')) { $opt{warn_once_on_nest} = 1; $opt{disable_old_special_ops} = 1; @@ -286,6 +301,11 @@ sub new { s/\A\s+//, s/\s+\Z// for $sql; return [ $sql, @bind ]; }; + $opt{expand_op}{ident} = sub { + my ($self, undef, $body) = @_; + $body = $body->from if Scalar::Util::blessed($body); + $self->_expand_ident(ident => $body); + }; } } @@ -326,6 +346,16 @@ sub make_binop_expander { } } +sub plugin { + my ($self, $plugin, @args) = @_; + unless (ref $plugin) { + $plugin =~ s/\A\+/${\__PACKAGE__}::Plugin::/; + require(join('/', split '::', $plugin).'.pm'); + } + $plugin->apply_to($self, @args); + return $self; +} + BEGIN { foreach my $type (qw( expand op_expand render op_render clause_expand clause_render @@ -333,8 +363,11 @@ BEGIN { my $name = join '_', reverse split '_', $type; my $singular = "${type}er"; - eval qq{sub ${singular} { shift->${singular}s(\@_) }; 1 } - or die "Method builder failed for ${singular}: $@"; + eval qq{sub ${singular} { + my \$self = shift; + return \$self->_ext_rw('${name}', \@_) if \@_ == 1; + return \$self->${singular}s(\@_) + }; 1 } or die "Method builder failed for ${singular}: $@"; eval qq{sub wrap_${singular} { shift->wrap_${singular}s(\@_) }; 1 } or die "Method builder failed for wrap_${singular}: $@"; @@ -439,12 +472,12 @@ sub insert { } sub _expand_insert_clause_target { - +(target => $_[0]->expand_maybe_list_expr($_[2], -ident)); + +(target => $_[0]->expand_expr($_[2], -ident)); } sub _expand_insert_clause_fields { return +{ -row => [ - $_[0]->expand_maybe_list_expr($_[2], -ident) + $_[0]->expand_expr({ -list => $_[2] }, -ident) ] } if ref($_[2]) eq 'ARRAY'; return $_[2]; # should maybe still expand somewhat? } @@ -462,7 +495,7 @@ sub _expand_insert_clause_from { } sub _expand_insert_clause_returning { - +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident)); + +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _expand_insert_values { @@ -523,9 +556,10 @@ sub _returning { my $f = $options->{returning}; my ($sql, @bind) = @{ $self->render_aqt( - $self->expand_maybe_list_expr($f, -ident) + $self->expand_expr({ -list => $f }, -ident) ) }; - return ($self->_sqlcase(' returning ').$sql, @bind); + my $rsql = $self->_sqlcase(' returning ').$sql; + return wantarray ? ($rsql, @bind) : $rsql; } sub _expand_insert_value { @@ -593,7 +627,7 @@ sub _update_set_values { sub _expand_update_set_values { my ($self, undef, $data) = @_; - $self->expand_maybe_list_expr( [ + $self->expand_expr({ -list => [ map { my ($k, $set) = @$_; $set = { -bind => $_ } unless defined $set; @@ -612,12 +646,12 @@ sub _expand_update_set_values { } ); } sort keys %$data - ] ); + ] }); } sub _expand_update_clause_target { my ($self, undef, $target) = @_; - +(target => $self->expand_maybe_list_expr($target, -ident)); + +(target => $self->expand_expr({ -list => $target }, -ident)); } sub _expand_update_clause_set { @@ -630,7 +664,7 @@ sub _expand_update_clause_where { } sub _expand_update_clause_returning { - +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident)); + +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } # So that subclasses can override UPDATE ... RETURNING separately from @@ -667,12 +701,12 @@ sub select { sub _expand_select_clause_select { my ($self, undef, $select) = @_; - +(select => $self->expand_maybe_list_expr($select, -ident)); + +(select => $self->expand_expr({ -list => $select }, -ident)); } sub _expand_select_clause_from { my ($self, undef, $from) = @_; - +(from => $self->expand_maybe_list_expr($from, -ident)); + +(from => $self->expand_expr({ -list => $from }, -ident)); } sub _expand_select_clause_where { @@ -725,9 +759,10 @@ sub _expand_select_clause_order_by { sub _select_fields { my ($self, $fields) = @_; return $fields unless ref($fields); - return @{ $self->render_aqt( - $self->expand_maybe_list_expr($fields, '-ident') + my ($sql, @bind) = @{ $self->render_aqt( + $self->expand_expr({ -list => $fields }, '-ident') ) }; + return wantarray ? ($sql, @bind) : $sql; } #====================================================================== @@ -754,13 +789,13 @@ sub delete { sub _delete_returning { shift->_returning(@_) } sub _expand_delete_clause_target { - +(target => $_[0]->expand_maybe_list_expr($_[2], -ident)); + +(target => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); } sub _expand_delete_clause_returning { - +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident)); + +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _render_delete_clause_target { @@ -1231,6 +1266,9 @@ sub _expand_op { if (my $exp = $self->{expand_op}{$op}) { return $self->$exp($op, \@opargs); } + if (List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { + return { -op => [ $op, @opargs ] }; + } +{ -op => [ $op, map $self->expand_expr($_), @opargs ] }; } @@ -1243,6 +1281,18 @@ sub _expand_bool { return $self->_expand_expr({ -ident => $v }); } +sub _expand_list { + my ($self, undef, $expr) = @_; + return { -op => [ + ',', map $self->expand_expr($_), + @{$expr->{-op}}[1..$#{$expr->{-op}}] + ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ','; + return +{ -op => [ ',', + map $self->expand_expr($_), + ref($expr) eq 'ARRAY' ? @$expr : $expr + ] }; +} + sub _expand_op_andor { my ($self, $logop, $v, $k) = @_; if (defined $k) { @@ -1641,7 +1691,7 @@ sub _expand_order_by { return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg); - return $self->expand_maybe_list_expr($arg) + return $self->expand_expr({ -list => $arg }) if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ','; my $expander = sub { @@ -1682,6 +1732,8 @@ sub _order_by { my $final_sql = $self->_sqlcase(' order by ').$sql; + return $final_sql unless wantarray; + return ($final_sql, @bind); } @@ -1720,7 +1772,7 @@ sub _table { my $self = shift; my $from = shift; $self->render_aqt( - $self->expand_maybe_list_expr($from, -ident) + $self->expand_expr({ -list => $from }, -ident) )->[0]; } @@ -1729,18 +1781,6 @@ sub _table { # UTILITY FUNCTIONS #====================================================================== -sub expand_maybe_list_expr { - my ($self, $expr, $default) = @_; - return { -op => [ - ',', map $self->expand_expr($_, $default), - @{$expr->{-op}}[1..$#{$expr->{-op}}] - ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ','; - return +{ -op => [ ',', - map $self->expand_expr($_, $default), - ref($expr) eq 'ARRAY' ? @$expr : $expr - ] }; -} - # highly optimized, as it's called way too often sub _quote { # my ($self, $label) = @_; @@ -3448,11 +3488,17 @@ When supplied with a coderef, it is called as: =back -=head1 NEW METHODS +=head1 NEW METHODS (EXPERIMENTAL) See L for the C versus C concept and an explanation of what the below extensions are extending. +=head2 plugin + + $sqla->plugin('+Foo'); + +Enables plugin SQL::Abstract::Plugin::Foo. + =head2 render_expr my ($sql, @bind) = $sqla->render_expr($expr); @@ -3471,12 +3517,6 @@ Expression expansion with optional default for scalars. my $aqt = $self->expand_expr($expr); my $aqt = $self->expand_expr($expr, -ident); -=head2 expand_maybe_list_expr - -expand_expr but with commas if there's more than one entry. - - my $aqt = $self->expand_maybe_list_expr([ @exprs ], $default?); - =head2 render_aqt Top level means avoid parens on statement AQT. @@ -3484,6 +3524,13 @@ Top level means avoid parens on statement AQT. my $res = $self->render_aqt($aqt, $top_level); my ($sql, @bind) = @$res; +=head2 join_query_parts + +Similar to join() but will render hashrefs as nodes for both join and parts, +and treats arrayref as a nested C<[ $join, @parts ]> structure. + + my $part = $self->join_query_parts($join, @parts); + =head1 NEW EXTENSION SYSTEM =head2 clone @@ -3589,6 +3636,39 @@ but excessive depth is avoided. my @list = $sqla->statement_list; +=head2 make_unop_expander + + my $exp = $sqla->make_unop_expander(sub { ... }); + +If the op is found as a binop, assumes it wants a default comparison, so +the inner expander sub can reliably operate as + + sub { my ($self, $name, $body) = @_; ... } + +=head2 make_binop_expander + + my $exp = $sqla->make_binop_expander(sub { ... }); + +If the op is found as a unop, assumes the value will be an arrayref with the +LHS as the first entry, and converts that to an ident node if it's a simple +scalar. So the inner expander sub looks like + + sub { + my ($self, $name, $body, $k) = @_; + { -blah => [ map $self->expand_expr($_), $k, $body ] } + } + +=head2 unop_expander + +=head2 unop_expanders + +=head2 binop_expander + +=head2 binop_expanders + +The above methods operate exactly like the op_ versions but wrap the coderef +using the appropriate make_ method first. + =head1 PERFORMANCE Thanks to some benchmarking by Mark Stosberg, it turns out that