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=b279856ba4651ca5288dfaa585eaaddca0b75f38;hb=cf5b7ab163f8ac123ebc9bb1156e79646cd5bd2f;hpb=04cde4cfad6c3172c31189ec3943d8ebf15959e9 diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index b279856..dda7fc5 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -8,7 +8,7 @@ use List::Util (); use Scalar::Util (); use Exporter 'import'; -our @EXPORT_OK = qw(is_plain_value is_literal_value); +our @EXPORT_OK = qw(is_plain_value is_literal_value is_undef_value); BEGIN { if ($] < 5.009_005) { @@ -144,20 +144,17 @@ our %Defaults = ( op => '_expand_op', func => '_expand_func', values => '_expand_values', - bind => '_expand_noop', - literal => '_expand_noop', - keyword => '_expand_noop', + list => '_expand_list', }, expand_op => { - 'between' => '_expand_between', - 'not_between' => '_expand_between', - 'in' => '_expand_in', - 'not_in' => '_expand_in', - 'nest' => '_expand_nest', + (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')), + qw(between not_between)), + (map +($_ => __PACKAGE__->make_binop_expander('_expand_in')), + qw(in not_in)), (map +($_ => '_expand_op_andor'), ('and', 'or')), (map +($_ => '_expand_op_is'), ('is', 'is_not')), - 'ident' => '_expand_ident', - 'value' => '_expand_value', + (map +($_ => __PACKAGE__->make_unop_expander("_expand_${_}")), + qw(ident value nest)), }, render => { (map +($_, "_render_$_"), @@ -282,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; @@ -290,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); + }; } } @@ -310,22 +326,52 @@ sub _ext_rw { return $self; } +sub make_unop_expander { + my (undef, $exp) = @_; + sub { + my ($self, $name, $body, $k) = @_; + return $self->_expand_hashpair_cmp($k, { "-${name}" => $body }) + if defined($k); + return $self->$exp($name, $body); + } +} + +sub make_binop_expander { + my (undef, $exp) = @_; + sub { + my ($self, $name, $body, $k) = @_; + $k = shift @{$body = [ @$body ]} unless defined $k; + $k = ref($k) ? $k : { -ident => $k }; + return $self->$exp($name, $body, $k); + } +} + +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 )) { my $name = join '_', reverse split '_', $type; my $singular = "${type}er"; - eval qq{sub ${singular} { shift->_ext_rw($name => \@_) }; 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} { - my (\$self, \$key, \$builder) = \@_; - my \$orig = \$self->_ext_rw('${name}', \$key); - \$self->_ext_rw( - '${name}', \$key, - \$builder->(\$orig, '${name}', \$key) - ); + shift->wrap_${singular}s(\@_) }; 1 } or die "Method builder failed for wrap_${singular}: $@"; + eval qq{sub ${singular}s { my (\$self, \@args) = \@_; while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { @@ -347,9 +393,23 @@ BEGIN { eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; } or die "Method builder failed for ${singular}_list: $@"; } + foreach my $singular (qw(unop_expander binop_expander)) { + eval qq{sub ${singular} { shift->${singular}s(\@_) }; 1 } + or die "Method builder failed for ${singular}: $@"; + eval qq{sub ${singular}s { + my (\$self, \@args) = \@_; + while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { + \$self->_ext_rw( + expand_op => \$this_key, + \$self->make_${singular}(\$this_value), + ); + } + return \$self; + }; 1 } or die "Method builder failed for ${singular}s: $@"; + } } -sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] } +#sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] } sub statement_list { sort keys %{$_[0]->{clauses_of}} } @@ -412,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? } @@ -427,7 +487,6 @@ sub _expand_insert_clause_from { if (ref($data) eq 'HASH' and (keys(%$data))[0] =~ /^-/) { return $self->expand_expr($data); } - return $data if ref($data) eq 'HASH' and $data->{-row}; my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data); return ( from => { -values => [ $v_aqt ] }, @@ -436,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 { @@ -497,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 { @@ -567,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; @@ -586,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 { @@ -604,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 @@ -641,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 { @@ -699,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; } #====================================================================== @@ -728,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 { @@ -858,7 +919,7 @@ sub _render_statement { sub _normalize_op { my ($self, $raw) = @_; my $op = lc $raw; - return $op if grep $_->{$op}, @{$self}{qw(is_op expand_op render_op)}; + return $op if grep $_->{$op}, @{$self}{qw(expand_op render_op)}; s/^-(?=.)//, s/\s+/_/g for $op; $op; } @@ -992,23 +1053,26 @@ sub _expand_hashpair_op { my $op = $self->_normalize_op($k); - { # Old SQLA compat + my $wsop = join(' ', split '_', $op); - my $op = join(' ', split '_', $op); + my $is_special = List::Util::first { $wsop =~ $_->{regex} } + @{$self->{special_ops}}; + + { # Old SQLA compat # the old special op system requires illegality for top-level use if ( (our $Expand_Depth) == 1 and ( - List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}} + $is_special or ( $self->{disable_old_special_ops} - and List::Util::first { $op =~ $_->{regex} } @BUILTIN_SPECIAL_OPS + and List::Util::first { $wsop =~ $_->{regex} } @BUILTIN_SPECIAL_OPS ) ) ) { - puke "Illegal use of top-level '-$op'" + puke "Illegal use of top-level '-$wsop'" } } @@ -1016,6 +1080,10 @@ sub _expand_hashpair_op { return $self->$exp($op, $v); } + if ($self->{render}{$op}) { + return { "-${op}" => $v }; + } + # Ops prefixed with -not_ get converted if (my ($rest) = $op =~/^not_(.*)$/) { @@ -1036,27 +1104,22 @@ sub _expand_hashpair_op { } } - my $type = ( - $self->{unknown_unop_always_func} && !$self->{render_op}{$op} - ? -func - : -op - ); + my $type = $is_special || $self->{render_op}{$op} ? -op : -func; - { # Old SQLA compat + if ($self->{restore_old_unop_handling}) { + + # Old SQLA compat if ( ref($v) eq 'HASH' and keys %$v == 1 and (keys %$v)[0] =~ /^-/ + and not $self->{render_op}{$op} + and not $is_special ) { - $type = ( - ( - (List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) - or $self->{render_op}{$op} - ) - ? -op - : -func - ) + $type = -func; + } else { + $type = -op; } } @@ -1175,10 +1238,7 @@ sub _expand_func { } sub _expand_ident { - my ($self, undef, $body, $k) = @_; - return $self->_expand_hashpair_cmp( - $k, { -ident => $body } - ) if defined($k); + my ($self, undef, $body) = @_; unless (defined($body) or (ref($body) and ref($body) eq 'ARRAY')) { puke "-ident requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts"; } @@ -1192,9 +1252,6 @@ sub _expand_ident { } sub _expand_value { - return $_[0]->_expand_hashpair_cmp( - $_[3], { -value => $_[2] }, - ) if defined($_[3]); +{ -bind => [ our $Cur_Col_Meta, $_[2] ] }; } @@ -1209,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 ] }; } @@ -1221,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) { @@ -1289,7 +1361,6 @@ sub _expand_op_is { sub _expand_between { my ($self, $op, $vv, $k) = @_; - $k = shift @{$vv = [ @$vv ]} unless defined $k; my @rhs = map $self->_expand_expr($_), ref($vv) eq 'ARRAY' ? @$vv : $vv; unless ( @@ -1301,14 +1372,13 @@ sub _expand_between { } return +{ -op => [ $op, - $self->expand_expr(ref($k) ? $k : { -ident => $k }), + $self->expand_expr($k), map $self->expand_expr($_, -value), @rhs ] } } sub _expand_in { my ($self, $op, $vv, $k) = @_; - $k = shift @{$vv = [ @$vv ]} unless defined $k; if (my $literal = is_literal_value($vv)) { my ($sql, @bind) = @$literal; my $opened_sql = $self->_open_outer_paren($sql); @@ -1353,11 +1423,6 @@ sub _expand_nest { return $self->_expand_expr($v); } -sub _expand_noop { - my ($self, $type, $v) = @_; - return { "-${type}" => $v }; -} - sub _expand_values { my ($self, undef, $values) = @_; return { -values => [ @@ -1433,7 +1498,9 @@ sub _render_literal { sub _render_keyword { my ($self, undef, $keyword) = @_; - return [ $self->_sqlcase(join ' ', split '_', $keyword) ]; + return [ $self->_sqlcase( + ref($keyword) ? $$keyword : join ' ', split '_', $keyword + ) ]; } sub _render_op { @@ -1566,8 +1633,14 @@ sub _render_unop_paren { sub _render_unop_prefix { my ($self, $op, $v) = @_; + my $op_sql = $self->{restore_old_unop_handling} + ? $self->_sqlcase($op) + : { -keyword => $op }; return $self->join_query_parts(' ', - $self->_sqlcase($op), $v->[0] + ($self->{restore_old_unop_handling} + ? $self->_sqlcase($op) + : { -keyword => \$op }), + $v->[0] ); } @@ -1618,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 { @@ -1659,6 +1732,8 @@ sub _order_by { my $final_sql = $self->_sqlcase(' order by ').$sql; + return $final_sql unless wantarray; + return ($final_sql, @bind); } @@ -1697,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]; } @@ -1706,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) = @_; @@ -1799,23 +1862,6 @@ sub _assert_bindval_matches_bindtype { } } -sub _join_sql_clauses { - my ($self, $logic, $clauses_aref, $bind_aref) = @_; - - if (@$clauses_aref > 1) { - my $join = " " . $self->_sqlcase($logic) . " "; - my $sql = '( ' . join($join, @$clauses_aref) . ' )'; - return ($sql, @$bind_aref); - } - elsif (@$clauses_aref) { - return ($clauses_aref->[0], @$bind_aref); # no parentheses - } - else { - return (); # if no SQL, ignore @$bind_aref - } -} - - # Fix SQL case, if so requested sub _sqlcase { # LDNOTE: if $self->{case} is true, then it contains 'lower', so we @@ -2644,6 +2690,10 @@ module: On failure returns C, on success returns an B reference containing the unpacked version of the supplied literal SQL and bind values. +=head2 is_undef_value + +Tests for undef, whether expanded or not. + =head1 WHERE CLAUSES =head2 Introduction @@ -3299,7 +3349,9 @@ forms. Examples: -=head1 SPECIAL OPERATORS +=head1 OLD EXTENSION SYSTEM + +=head2 SPECIAL OPERATORS my $sqlmaker = SQL::Abstract->new(special_ops => [ { @@ -3384,7 +3436,7 @@ of the MATCH .. AGAINST syntax for MySQL ]); -=head1 UNARY OPERATORS +=head2 UNARY OPERATORS my $sqlmaker = SQL::Abstract->new(unary_ops => [ { @@ -3436,6 +3488,186 @@ When supplied with a coderef, it is called as: =back +=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); + +=head2 render_statement + +Use this if you may be rendering a top level statement so e.g. a SELECT +query doesn't get wrapped in parens + + my ($sql, @bind) = $sqla->render_statement($expr); + +=head2 expand_expr + +Expression expansion with optional default for scalars. + + my $aqt = $self->expand_expr($expr); + my $aqt = $self->expand_expr($expr, -ident); + +=head2 render_aqt + +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 + + my $sqla2 = $sqla->clone; + +Performs a semi-shallow copy such that extension methods won't leak state +but excessive depth is avoided. + +=head2 expander + +=head2 expanders + +=head2 op_expander + +=head2 op_expanders + +=head2 clause_expander + +=head2 clause_expanders + + $sqla->expander('name' => sub { ... }); + $sqla->expanders('name1' => sub { ... }, 'name2' => sub { ... }); + +=head2 expander_list + +=head2 op_expander_list + +=head2 clause_expander_list + + my @names = $sqla->expander_list; + +=head2 wrap_expander + +=head2 wrap_expanders + +=head2 wrap_op_expander + +=head2 wrap_op_expanders + +=head2 wrap_clause_expander + +=head2 wrap_clause_expanders + + $sqla->wrap_expander('name' => sub { my ($orig) = @_; sub { ... } }); + $sqla->wrap_expanders( + 'name1' => sub { my ($orig1) = @_; sub { ... } }, + 'name2' => sub { my ($orig2) = @_; sub { ... } }, + ); + +=head2 renderer + +=head2 renderers + +=head2 op_renderer + +=head2 op_renderers + +=head2 clause_renderer + +=head2 clause_renderers + + $sqla->renderer('name' => sub { ... }); + $sqla->renderers('name1' => sub { ... }, 'name2' => sub { ... }); + +=head2 renderer_list + +=head2 op_renderer_list + +=head2 clause_renderer_list + + my @names = $sqla->renderer_list; + +=head2 wrap_renderer + +=head2 wrap_renderers + +=head2 wrap_op_renderer + +=head2 wrap_op_renderers + +=head2 wrap_clause_renderer + +=head2 wrap_clause_renderers + + $sqla->wrap_renderer('name' => sub { my ($orig) = @_; sub { ... } }); + $sqla->wrap_renderers( + 'name1' => sub { my ($orig1) = @_; sub { ... } }, + 'name2' => sub { my ($orig2) = @_; sub { ... } }, + ); + +=head2 clauses_of + + my @clauses = $sqla->clauses_of('select'); + $sqla->clauses_of(select => \@new_clauses); + $sqla->clauses_of(select => sub { + my (undef, @old_clauses) = @_; + ... + return @new_clauses; + }); + +=head2 statement_list + + 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