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=4ba4b76c2c8fbcc68aae5e252875ab77df708af0;hp=4f136d624e8df1e9a057d9d53806db6ccc290bcb;hb=203af7d68ff6896e3196e3f072caf65b33dfd719;hpb=6d626065c2395f7a0863ae7c858b7b56aa715b4e diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 4f136d6..4ba4b76 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,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')), @@ -326,6 +327,16 @@ sub make_binop_expander { } } +sub plugin { + my ($self, $plugin, @args) = @_; + unless (ref $plugin) { + $plugin =~ s/\A\+/${\ref($self)}::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 @@ -367,7 +378,7 @@ BEGIN { my (\$self, \@args) = \@_; while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { \$self->_ext_rw( - op => \$this_key, + expand_op => \$this_key, \$self->make_${singular}(\$this_value), ); } @@ -376,7 +387,7 @@ BEGIN { } } -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}} } @@ -439,12 +450,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 +473,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,7 +534,7 @@ 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); } @@ -593,7 +604,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 +623,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 +641,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 +678,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 { @@ -726,7 +737,7 @@ sub _select_fields { my ($self, $fields) = @_; return $fields unless ref($fields); return @{ $self->render_aqt( - $self->expand_maybe_list_expr($fields, '-ident') + $self->expand_expr({ -list => $fields }, '-ident') ) }; } @@ -754,13 +765,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 { @@ -884,7 +895,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; } @@ -1243,6 +1254,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 +1664,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 { @@ -1720,7 +1743,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 +1752,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) = @_; @@ -2650,6 +2661,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 @@ -3444,13 +3459,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 +=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