X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=d8b7e96ae8e33b01c82bd7952bdf0cef65a8bd5f;hb=7a8e09eeec71ff0be4bd110804bf412d70d5687c;hp=53484e60394562bca8294b47615a5d7fdfe92968;hpb=0ac94f429b045223ab8f8c390ce76f7303267c89;p=scpubgit%2FQ-Branch.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 53484e6..d8b7e96 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -139,29 +139,19 @@ sub is_plain_value ($) { our %Defaults = ( expand => { - not => '_expand_not', bool => '_expand_bool', - and => '_expand_op_andor', - or => '_expand_op_andor', - nest => '_expand_nest', - bind => '_expand_bind', - in => '_expand_in', - not_in => '_expand_in', row => '_expand_row', - between => '_expand_between', - not_between => '_expand_between', op => '_expand_op', - (map +($_ => '_expand_op_is'), ('is', 'is_not')), - ident => '_expand_ident', - value => '_expand_value', func => '_expand_func', values => '_expand_values', }, expand_op => { - 'between' => '_expand_between', - 'not_between' => '_expand_between', - 'in' => '_expand_in', - 'not_in' => '_expand_in', + (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')), + qw(between not_between)), + #(map +($_ => __PACKAGE__->make_binop_expander('_expand_in')), + # qw(in not_in)), + in => '_expand_in', + not_in => '_expand_in', 'nest' => '_expand_nest', (map +($_ => '_expand_op_andor'), ('and', 'or')), (map +($_ => '_expand_op_is'), ('is', 'is_not')), @@ -169,7 +159,8 @@ our %Defaults = ( 'value' => '_expand_value', }, render => { - (map +($_, "_render_$_"), qw(op func bind ident literal row values)), + (map +($_, "_render_$_"), + qw(op func bind ident literal row values keyword)), }, render_op => { (map +($_ => '_render_op_between'), 'between', 'not_between'), @@ -185,6 +176,7 @@ our %Defaults = ( delete => [ qw(target where returning) ], update => [ qw(target set where returning) ], insert => [ qw(target fields from returning) ], + select => [ qw(select from where order_by) ], }, expand_clause => { 'delete.from' => '_expand_delete_clause_target', @@ -242,11 +234,6 @@ sub new { # special operators $opt{special_ops} ||= []; - if ($class->isa('DBIx::Class::SQLMaker')) { - $opt{warn_once_on_nest} = 1; - $opt{disable_old_special_ops} = 1; - } - # unary operators $opt{unary_ops} ||= []; @@ -270,14 +257,38 @@ sub new { $opt{$name} = { %{$Defaults{$name}}, %{$opt{$name}||{}} }; } - foreach my $type (qw(insert update delete)) { - my $method = "_${type}_returning"; - if ($class ne __PACKAGE__ - and __PACKAGE__->can($method) ne $class->can($method)) { - my $clause = "${type}.returning"; - $opt{expand_clause}{$clause} = sub { $_[2] }, - $opt{render_clause}{$clause} - = sub { [ $_[0]->$method($_[3]) ] }; + if ($class ne __PACKAGE__) { + + # check for overriden methods + + foreach my $type (qw(insert update delete)) { + my $method = "_${type}_returning"; + if (__PACKAGE__->can($method) ne $class->can($method)) { + my $clause = "${type}.returning"; + $opt{expand_clause}{$clause} = sub { $_[2] }, + $opt{render_clause}{$clause} + = sub { [ $_[0]->$method($_[3]) ] }; + } + } + if (__PACKAGE__->can('_table') ne $class->can('_table')) { + $opt{expand_clause}{'select.from'} = sub { + return +{ -literal => [ $_[0]->_table($_[2]) ] }; + }; + } + if (__PACKAGE__->can('_order_by') ne $class->can('_order_by')) { + $opt{expand_clause}{'select.order_by'} = sub { $_[2] }; + $opt{render_clause}{'select.order_by'} = sub { + [ $_[0]->_order_by($_[2]) ]; + }; + } + if ($class->isa('DBIx::Class::SQLMaker')) { + $opt{warn_once_on_nest} = 1; + $opt{disable_old_special_ops} = 1; + $opt{render_clause}{'select.where'} = sub { + my ($sql, @bind) = $_[0]->where($_[2]); + s/\A\s+//, s/\s+\Z// for $sql; + return [ $sql, @bind ]; + }; } } @@ -291,6 +302,102 @@ sub new { return bless \%opt, $class; } +sub _ext_rw { + my ($self, $name, $key, $value) = @_; + return $self->{$name}{$key} unless @_ > 3; + $self->{$name}{$key} = $value; + 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); + } +} + +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 wrap_${singular} { + my (\$self, \$key, \$builder) = \@_; + my \$orig = \$self->_ext_rw('${name}', \$key); + \$self->_ext_rw( + '${name}', \$key, + \$builder->(\$orig, '${name}', \$key) + ); + }; 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)) { + \$self->_ext_rw('${name}', \$this_key, \$this_value); + } + return \$self; + }; 1 } or die "Method builder failed for ${singular}s: $@"; + eval qq{sub wrap_${singular}s { + my (\$self, \@args) = \@_; + while (my (\$this_key, \$this_builder) = splice(\@args, 0, 2)) { + my \$orig = \$self->_ext_rw('${name}', \$this_key); + \$self->_ext_rw( + '${name}', \$this_key, + \$this_builder->(\$orig, '${name}', \$this_key), + ); + } + return \$self; + }; 1 } or die "Method builder failed for wrap_${singular}s: $@"; + eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; } + or die "Method builder failed for ${singular}_list: $@"; + } +} + +sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] } + +sub statement_list { sort keys %{$_[0]->{clauses_of}} } + +sub clauses_of { + my ($self, $of, @clauses) = @_; + unless (@clauses) { + return @{$self->{clauses_of}{$of}||[]}; + } + if (ref($clauses[0]) eq 'CODE') { + @clauses = $self->${\($clauses[0])}(@{$self->{clauses_of}{$of}||[]}); + } + $self->{clauses_of}{$of} = \@clauses; + return $self; +} + +sub clone { + my ($self) = @_; + bless( + { + (map +($_ => ( + ref($self->{$_}) eq 'HASH' + ? { %{$self->{$_}} } + : $self->{$_} + )), keys %$self), + }, + ref($self) + ); +} + sub sqltrue { +{ -literal => [ $_[0]->{sqltrue} ] } } sub sqlfalse { +{ -literal => [ $_[0]->{sqlfalse} ] } } @@ -324,12 +431,12 @@ sub insert { } sub _expand_insert_clause_target { - +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); + +(target => $_[0]->expand_maybe_list_expr($_[2], -ident)); } sub _expand_insert_clause_fields { return +{ -row => [ - $_[0]->_expand_maybe_list_expr($_[2], -ident) + $_[0]->expand_maybe_list_expr($_[2], -ident) ] } if ref($_[2]) eq 'ARRAY'; return $_[2]; # should maybe still expand somewhat? } @@ -339,7 +446,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 ] }, @@ -348,7 +454,7 @@ sub _expand_insert_clause_from { } sub _expand_insert_clause_returning { - +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); + +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident)); } sub _expand_insert_values { @@ -387,7 +493,7 @@ sub _render_insert_clause_fields { sub _render_insert_clause_target { my ($self, undef, $from) = @_; - $self->join_query_parts(' ', $self->format_keyword('insert into'), $from); + $self->join_query_parts(' ', { -keyword => 'insert into' }, $from); } sub _render_insert_clause_from { @@ -409,7 +515,7 @@ sub _returning { my $f = $options->{returning}; my ($sql, @bind) = @{ $self->render_aqt( - $self->_expand_maybe_list_expr($f, -ident) + $self->expand_maybe_list_expr($f, -ident) ) }; return ($self->_sqlcase(' returning ').$sql, @bind); } @@ -466,7 +572,7 @@ sub update { sub _render_update_clause_target { my ($self, undef, $target) = @_; - $self->join_query_parts(' ', $self->format_keyword('update'), $target); + $self->join_query_parts(' ', { -keyword => 'update' }, $target); } sub _update_set_values { @@ -479,7 +585,7 @@ sub _update_set_values { sub _expand_update_set_values { my ($self, undef, $data) = @_; - $self->_expand_maybe_list_expr( [ + $self->expand_maybe_list_expr( [ map { my ($k, $set) = @$_; $set = { -bind => $_ } unless defined $set; @@ -503,7 +609,7 @@ sub _expand_update_set_values { sub _expand_update_clause_target { my ($self, undef, $target) = @_; - +(target => $self->_expand_maybe_list_expr($target, -ident)); + +(target => $self->expand_maybe_list_expr($target, -ident)); } sub _expand_update_clause_set { @@ -516,7 +622,7 @@ sub _expand_update_clause_where { } sub _expand_update_clause_returning { - +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); + +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident)); } # So that subclasses can override UPDATE ... RETURNING separately from @@ -529,31 +635,90 @@ sub _update_returning { shift->_returning(@_) } # SELECT #====================================================================== - sub select { - my $self = shift; - my $table = $self->_table(shift); - my $fields = shift || '*'; - my $where = shift; - my $order = shift; + my ($self, @args) = @_; + my $stmt = do { + if (ref(my $sel = $args[0]) eq 'HASH') { + $sel + } else { + my %clauses; + @clauses{qw(from select where order_by)} = @args; + + # This oddity is to literalify since historically SQLA doesn't quote + # a single identifier argument, so we convert it into a literal + + $clauses{select} = { -literal => [ $clauses{select}||'*' ] } + unless ref($clauses{select}); + \%clauses; + } + }; - my ($fields_sql, @bind) = $self->_select_fields($fields); + my @rendered = $self->render_statement({ -select => $stmt }); + return wantarray ? @rendered : $rendered[0]; +} - my ($where_sql, @where_bind) = $self->where($where, $order); - push @bind, @where_bind; +sub _expand_select_clause_select { + my ($self, undef, $select) = @_; + +(select => $self->expand_maybe_list_expr($select, -ident)); +} - my $sql = join(' ', $self->_sqlcase('select'), $fields_sql, - $self->_sqlcase('from'), $table) - . $where_sql; +sub _expand_select_clause_from { + my ($self, undef, $from) = @_; + +(from => $self->expand_maybe_list_expr($from, -ident)); +} + +sub _expand_select_clause_where { + my ($self, undef, $where) = @_; + + my $sqla = do { + if (my $conv = $self->{convert}) { + my $_wrap = sub { + my $orig = shift; + sub { + my $self = shift; + +{ -func => [ + $conv, + $self->$orig(@_) + ] }; + }; + }; + $self->clone + ->wrap_expander(bind => $_wrap) + ->wrap_op_expanders(map +($_ => $_wrap), qw(ident value)) + ->wrap_expander(func => sub { + my $orig = shift; + sub { + my ($self, $type, $thing) = @_; + if (ref($thing) eq 'ARRAY' and $thing->[0] eq $conv + and @$thing == 2 and ref($thing->[1]) eq 'HASH' + and ( + $thing->[1]{-ident} + or $thing->[1]{-value} + or $thing->[1]{-bind}) + ) { + return { -func => $thing }; # already went through our expander + } + return $self->$orig($type, $thing); + } + }); + } else { + $self; + } + }; - return wantarray ? ($sql, @bind) : $sql; + return +(where => $sqla->expand_expr($where)); +} + +sub _expand_select_clause_order_by { + my ($self, undef, $order_by) = @_; + +(order_by => $self->_expand_order_by($order_by)); } sub _select_fields { my ($self, $fields) = @_; return $fields unless ref($fields); return @{ $self->render_aqt( - $self->_expand_maybe_list_expr($fields, '-ident') + $self->expand_maybe_list_expr($fields, '-ident') ) }; } @@ -581,18 +746,18 @@ sub delete { sub _delete_returning { shift->_returning(@_) } sub _expand_delete_clause_target { - +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); + +(target => $_[0]->expand_maybe_list_expr($_[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_maybe_list_expr($_[2], -ident)); } sub _render_delete_clause_target { my ($self, undef, $from) = @_; - $self->join_query_parts(' ', $self->format_keyword('delete from'), $from); + $self->join_query_parts(' ', { -keyword => 'delete from' }, $from); } #====================================================================== @@ -695,7 +860,7 @@ sub _render_statement { my $r = $self->render_aqt($clause_expr, 1); next unless defined $r->[0] and length $r->[0]; $self->join_query_parts(' ', - $self->format_keyword($clause), + { -keyword => $clause }, $r ); } @@ -845,30 +1010,37 @@ 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'" } } - if (my $exp = $self->{expand}{$op}) { + if (my $exp = $self->{expand}{$op}||$self->{expand_op}{$op}) { return $self->$exp($op, $v); } + if ($self->{render}{$op}) { + return { "-${op}" => $v }; + } + # Ops prefixed with -not_ get converted if (my ($rest) = $op =~/^not_(.*)$/) { @@ -889,36 +1061,30 @@ sub _expand_hashpair_op { } } - # an explicit node type is currently assumed to be expanded (this is almost - # certainly wrong and there should be expansion anyway) + my $type = $is_special || $self->{render_op}{$op} ? -op : -func; - if ($self->{render}{$op}) { - return { $k => $v }; - } - - my $type = $self->{unknown_unop_always_func} ? -func : -op; + if ($self->{restore_old_unop_handling}) { - { # Old SQLA compat + # 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}}) - ? -op - : -func - ) + $type = -func; + } else { + $type = -op; } } - return +{ $type => [ - $op, - ($type eq -func and ref($v) eq 'ARRAY') - ? map $self->_expand_expr($_), @$v - : $self->_expand_expr($v) - ] }; + if ($type eq -func and ref($v) eq 'ARRAY') { + return $self->_expand_expr({ -func => [ $op, @$v ] }); + } + + return $self->_expand_expr({ $type => [ $op, $v ] }); } sub _expand_hashpair_cmp { @@ -1052,10 +1218,6 @@ sub _expand_value { +{ -bind => [ our $Cur_Col_Meta, $_[2] ] }; } -sub _expand_not { - +{ -op => [ 'not', $_[0]->_expand_expr($_[2]) ] }; -} - sub _expand_row { my ($self, undef, $args) = @_; +{ -row => [ map $self->expand_expr($_), @$args ] }; @@ -1147,7 +1309,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 ( @@ -1159,8 +1320,8 @@ sub _expand_between { } return +{ -op => [ $op, - $self->expand_expr(ref($k) ? $k : { -ident => $k }), - @rhs + $self->expand_expr($k), + map $self->expand_expr($_, -value), @rhs ] } } @@ -1211,11 +1372,6 @@ sub _expand_nest { return $self->_expand_expr($v); } -sub _expand_bind { - my ($self, undef, $bind) = @_; - return { -bind => $bind }; -} - sub _expand_values { my ($self, undef, $values) = @_; return { -values => [ @@ -1228,12 +1384,12 @@ sub _expand_values { } sub _recurse_where { - my ($self, $where, $logic) = @_; + my ($self, $where) = @_; # Special case: top level simple string treated as literal my $where_exp = (ref($where) - ? $self->_expand_expr($where, $logic) + ? $self->_expand_select_clause_where(undef, $where) : { -literal => [ $where ] }); # dispatch expanded expression @@ -1253,7 +1409,7 @@ sub _recurse_where { sub _render_ident { my ($self, undef, $ident) = @_; - return [ $self->_convert($self->_quote($ident)) ]; + return [ $self->_quote($ident) ]; } sub _render_row { @@ -1280,7 +1436,7 @@ sub _render_func { sub _render_bind { my ($self, undef, $bind) = @_; - return [ $self->_convert('?'), $self->_bindtype(@$bind) ]; + return [ '?', $self->_bindtype(@$bind) ]; } sub _render_literal { @@ -1289,6 +1445,13 @@ sub _render_literal { return $literal; } +sub _render_keyword { + my ($self, undef, $keyword) = @_; + return [ $self->_sqlcase( + ref($keyword) ? $$keyword : join ' ', split '_', $keyword + ) ]; +} + sub _render_op { my ($self, undef, $v) = @_; my ($op, @args) = @$v; @@ -1333,11 +1496,11 @@ sub _render_op_between { unless $low->{-literal}; $low; } else { - +($low, $self->format_keyword('and'), $high); + +($low, { -keyword => 'and' }, $high); } }; return $self->join_query_parts(' ', - '(', $left, $self->format_keyword($op), @rh, ')', + '(', $left, { -keyword => $op }, @rh, ')', ); } @@ -1347,7 +1510,7 @@ sub _render_op_in { return $self->join_query_parts(' ', $lhs, - $self->format_keyword($op), + { -keyword => $op }, $self->join_query_parts(' ', '(', $self->join_query_parts(', ', @rhs), @@ -1374,7 +1537,7 @@ sub _render_op_multop { return $self->render_aqt($parts[0]) if @parts == 1; my $join = ($op eq ',' ? ', ' - : ' '.$self->format_keyword($op).' ' + : { -keyword => " ${op} " } ); return $self->join_query_parts($join, @parts); } @@ -1382,7 +1545,7 @@ sub _render_op_multop { sub _render_values { my ($self, undef, $values) = @_; my $inner = $self->join_query_parts(' ', - $self->format_keyword('values'), + { -keyword => 'values' }, $self->join_query_parts(', ', ref($values) eq 'ARRAY' ? @$values : $values ), @@ -1394,13 +1557,18 @@ sub _render_values { sub join_query_parts { my ($self, $join, @parts) = @_; + if (ref($join) eq 'HASH') { + $join = $self->render_aqt($join)->[0]; + } my @final = map +( ref($_) eq 'HASH' ? $self->render_aqt($_) : ((ref($_) eq 'ARRAY') ? $_ : [ $_ ]) ), @parts; return [ - $self->{join_sql_parts}->($join, grep defined, map $_->[0], @final), + $self->{join_sql_parts}->( + $join, grep defined && length, map $_->[0], @final + ), (map @{$_}[1..$#$_], @final), ]; } @@ -1414,15 +1582,21 @@ 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] ); } sub _render_unop_postfix { my ($self, $op, $v) = @_; return $self->join_query_parts(' ', - $v->[0], $self->format_keyword($op), + $v->[0], { -keyword => $op }, ); } @@ -1466,7 +1640,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_maybe_list_expr($arg) if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ','; my $expander = sub { @@ -1545,7 +1719,7 @@ sub _table { my $self = shift; my $from = shift; $self->render_aqt( - $self->_expand_maybe_list_expr($from, -ident) + $self->expand_maybe_list_expr($from, -ident) )->[0]; } @@ -1554,7 +1728,7 @@ sub _table { # UTILITY FUNCTIONS #====================================================================== -sub _expand_maybe_list_expr { +sub expand_maybe_list_expr { my ($self, $expr, $default) = @_; return { -op => [ ',', map $self->expand_expr($_, $default), @@ -1616,7 +1790,7 @@ sub _convert { #my ($self, $arg) = @_; if (my $conv = $_[0]->{convert_where}) { return @{ $_[0]->join_query_parts('', - $_[0]->format_keyword($conv), + $_[0]->_sqlcase($conv), '(' , $_[1] , ')' ) }; } @@ -1647,23 +1821,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 @@ -1671,8 +1828,6 @@ sub _sqlcase { return $_[0]->{case} ? $_[1] : uc($_[1]); } -sub format_keyword { $_[0]->_sqlcase(join ' ', split '_', $_[1]) } - #====================================================================== # DISPATCHING FROM REFKIND #======================================================================