X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=91d18986f4fde392faabebe6efacfa0c5db22d6d;hb=49781e5eb9e8ba816c26e5649f388be92a527e46;hp=a8b771f324177f32dedd1c5f4308aea7a36c159a;hpb=e90782e3e5e44cc2d65fe4ebdc14c1712152682f;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index a8b771f..91d1898 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) { @@ -28,7 +28,7 @@ BEGIN { # GLOBALS #====================================================================== -our $VERSION = '1.86'; +our $VERSION = '1.90_02'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -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,33 @@ 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 + ); + }; + } + foreach my $type (qw(in between)) { + my $meth = "_where_field_".uc($type); + if (__PACKAGE__->can($meth) ne $class->can($meth)) { + my $exp = sub { + my ($self, $op, $v, $k) = @_; + $op = join ' ', split '_', $op; + return +{ -literal => [ + $self->$meth($k, $op, $v) + ] }; + }; + $opt{expand_op}{$_} = $exp for $type, "not_${type}"; + } + } if ($class->isa('DBIx::Class::SQLMaker')) { $opt{warn_once_on_nest} = 1; $opt{disable_old_special_ops} = 1; @@ -286,6 +314,36 @@ sub new { s/\A\s+//, s/\s+\Z// for $sql; return [ $sql, @bind ]; }; + $opt{expand_op}{ident} = $class->make_unop_expander(sub { + my ($self, undef, $body) = @_; + $body = $body->from if Scalar::Util::blessed($body); + $self->_expand_ident(ident => $body); + }); + } + if ($class->isa('SQL::Abstract::More')) { + $opt{expand_op}{or} = sub { + my ($self, $logop, $v, $k) = @_; + if ($k and ref($v) eq 'ARRAY') { + my ($type, $val) = @$v; + my $op = $self->{cmp}; + if ( + ref($type) eq 'HASH' and ref($val) eq 'HASH' + and keys %$type == 1 and keys %$val == 1 + and (keys %$type)[0] eq (keys %$val)[0] + ) { + ($op) = keys %$type; + ($type) = values %$type; + ($val) = values %$val; + } + if ($self->is_bind_value_with_type(my $v = [ $type, $val ])) { + return $self->_expand_hashpair($k, { $op, { -bind => $v } }); + } + } + return $self->_expand_op_andor($logop, $v, $k); + }; + $opt{render}{bind} = sub { + return [ '?', map +(ref($_->[0]) ? $_ : $_->[1]), $_[2] ] + }; } } @@ -326,6 +384,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 +401,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}: $@"; @@ -376,7 +447,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 +510,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 +533,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 +594,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 +665,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 +684,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 +702,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 +739,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 +797,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 +827,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 +957,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; } @@ -896,7 +969,7 @@ sub _expand_expr { if (ref($expr) eq 'HASH') { return undef unless my $kc = keys %$expr; if ($kc > 1) { - return $self->_expand_op_andor(and => $expr); + return $self->_expand_logop(and => $expr); } my ($key, $value) = %$expr; if ($key =~ /^-/ and $key =~ s/ [_\s]? \d+ $//x ) { @@ -906,7 +979,7 @@ sub _expand_expr { return $self->_expand_hashpair($key, $value); } if (ref($expr) eq 'ARRAY') { - return $self->_expand_op_andor(lc($self->{logic}), $expr); + return $self->_expand_logop(lc($self->{logic}), $expr); } if (my $literal = is_literal_value($expr)) { return +{ -literal => $literal }; @@ -928,7 +1001,7 @@ sub _expand_hashpair { } if ($k =~ /^-./) { return $self->_expand_hashpair_op($k, $v); - } elsif ($k =~ /^[^\w]/i) { + } elsif ($k =~ /^\W+$/) { my ($lhs, @rhs) = ref($v) eq 'ARRAY' ? @$v : $v; return $self->_expand_op( -op, [ $k, $self->expand_expr($lhs, -ident), @rhs ] @@ -945,7 +1018,7 @@ sub _expand_hashpair_ident { # hash with multiple or no elements is andor if (ref($v) eq 'HASH' and keys %$v != 1) { - return $self->_expand_op_andor(and => $v, $k); + return $self->_expand_logop(and => $v, $k); } # undef needs to be re-sent with cmp to achieve IS/IS NOT NULL @@ -976,7 +1049,7 @@ sub _expand_hashpair_ident { ? (shift(@{$v = [ @$v ]}), $1) : lc($self->{logic} || 'OR') ); - return $self->_expand_op_andor( + return $self->_expand_logop( $logic => $v, $k ); } @@ -1153,7 +1226,7 @@ sub _expand_hashtriple { "operator '%s' applied on an empty array (field '$k')" ) ? $self->sqlfalse : $self->sqltrue); } - return $self->_expand_op_andor($logic => \@values, $k); + return $self->_expand_logop($logic => \@values, $k); } if (is_undef_value($vv)) { my $is = ($self->_dwim_op_to_is($op, @@ -1231,6 +1304,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 +1319,23 @@ 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_logop { + my ($self, $logop, $v, $k) = @_; + $self->${\$self->{expand_op}{$logop}}($logop, $v, $k); +} + sub _expand_op_andor { my ($self, $logop, $v, $k) = @_; if (defined $k) { @@ -1631,6 +1724,25 @@ sub _open_outer_paren { $sql; } +sub _where_field_IN { + my ($self, $k, $op, $vals) = @_; + @{$self->_render_op_in( + $op, + [ + $self->expand_expr($k, -ident), + map $self->expand_expr($_, -value), + ref($vals) eq 'ARRAY' ? @$vals : $vals + ] + )}; +} + +sub _where_field_BETWEEN { + my ($self, $k, $op, $vals) = @_; + @{$self->_render_op_between( + $op, + [ $self->expand_expr($k, -ident), ref($vals) eq 'ARRAY' ? @$vals : $vals ] + )}; +} #====================================================================== # ORDER BY @@ -1641,7 +1753,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 +1794,8 @@ sub _order_by { my $final_sql = $self->_sqlcase(' order by ').$sql; + return $final_sql unless wantarray; + return ($final_sql, @bind); } @@ -1720,7 +1834,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 +1843,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 +2752,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 +3550,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