X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=d0aae082b1596a198b2b9aca02355631f73d2b29;hb=2d64004f36ccaf869eaa059d153df080e16ff1e4;hp=f31fb535af11fc29c6c88ee299cd187bcfb8575c;hpb=9ade906e82820a00f2246603d2aa584a6359ae9d;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index f31fb53..d0aae08 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -27,7 +27,7 @@ BEGIN { # GLOBALS #====================================================================== -our $VERSION = '1.84'; +our $VERSION = '1.86'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -53,6 +53,9 @@ my @BUILTIN_UNARY_OPS = ( { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' }, { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' }, { regex => qr/^ value $/xi, handler => '_where_op_VALUE' }, + { regex => qr/^ op $/xi, handler => '_where_op_OP' }, + { regex => qr/^ bind $/xi, handler => '_where_op_BIND' }, + { regex => qr/^ literal $/xi, handler => '_where_op_LITERAL' }, ); #====================================================================== @@ -330,7 +333,7 @@ sub _insert_value { push @all_bind, @bind; }, - # THINK : anything useful to do with a HASHREF ? + # THINK: anything useful to do with a HASHREF ? HASHREF => sub { # (nothing, but old SQLA passed it through) #TODO in SQLA >= 2.0 it will die instead belch "HASH ref as bind value in insert is not supported"; @@ -372,7 +375,7 @@ sub update { unless ref $data eq 'HASH'; my ($sql, @all_bind) = $self->_update_set_values($data); - $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ') + $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ') . $sql; if ($where) { @@ -464,17 +467,24 @@ sub select { my $where = shift; my $order = shift; - my($where_sql, @bind) = $self->where($where, $order); + my ($fields_sql, @bind) = $self->_select_fields($fields); - my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields - : $fields; - my $sql = join(' ', $self->_sqlcase('select'), $f, + my ($where_sql, @where_bind) = $self->where($where, $order); + push @bind, @where_bind; + + my $sql = join(' ', $self->_sqlcase('select'), $fields_sql, $self->_sqlcase('from'), $table) . $where_sql; return wantarray ? ($sql, @bind) : $sql; } +sub _select_fields { + my ($self, $fields) = @_; + return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields + : $fields; +} + #====================================================================== # DELETE #====================================================================== @@ -487,7 +497,7 @@ sub delete { my $options = shift; my($where_sql, @bind) = $self->where($where); - my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql; + my $sql = $self->_sqlcase('delete from ') . $table . $where_sql; if ($options->{returning}) { my ($returning_sql, @returning_bind) = $self->_delete_returning($options); @@ -516,7 +526,7 @@ sub where { # where ? my ($sql, @bind) = $self->_recurse_where($where); - $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : ''; + $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : ''; # order by? if ($order) { @@ -528,14 +538,138 @@ sub where { return wantarray ? ($sql, @bind) : $sql; } +sub _expand_expr { + my ($self, $expr, $logic) = @_; + if (ref($expr) eq 'HASH') { + if (keys %$expr > 1) { + $logic ||= 'and'; + return +{ "-${logic}" => [ + map $self->_expand_expr_hashpair($_ => $expr->{$_}, $logic), + sort keys %$expr + ] }; + } + return $self->_expand_expr_hashpair(%$expr, $logic); + } + if (ref($expr) eq 'ARRAY') { + $logic = lc($logic || $self->{logic}); + $logic eq 'and' or $logic eq 'or' or puke "unknown logic: $logic"; + + my @expr = @$expr; + + my @res; + + while (my ($el) = splice @expr, 0, 1) { + puke "Supplying an empty left hand side argument is not supported in array-pairs" + unless defined($el) and length($el); + my $elref = ref($el); + if (!$elref) { + push(@res, $self->_expand_expr({ $el, shift(@expr) })); + } elsif ($elref eq 'ARRAY') { + push(@res, $self->_expand_expr($el)) if @$el; + } elsif (is_literal_value($el)) { + push @res, $el; + } elsif ($elref eq 'HASH') { + push @res, $self->_expand_expr($el); + } else { + die "unimplemented" + } + } + return { '-'.$logic => \@res }; + } + if (my $literal = is_literal_value($expr)) { + return +{ -literal => $literal }; + } + return $expr; +} + +sub _expand_expr_hashpair { + my ($self, $k, $v, $logic) = @_; + unless (defined($k) and length($k)) { + if (defined($k) and my $literal = is_literal_value($v)) { + belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; + return { -literal => $literal }; + } + puke "Supplying an empty left hand side argument is not supported"; + } + if ($k =~ /^-/) { + if ($k eq '-nest') { + return $self->_expand_expr($v); + } + if ($k eq '-bool') { + if (ref($v)) { + return $self->_expand_expr($v); + } + puke "-bool => undef not supported" unless defined($v); + return { -ident => $v }; + } + if (my ($rest) = $k =~/^-not[_ ](.*)$/) { + return $self->_expand_expr({ -not => { "-${rest}", $v } }, $logic); + } + } else { + unless (defined($v)) { + my $orig_op = my $op = $self->{cmp}; + my $is = + $op =~ /^not$/i ? 'is not' # legacy + : $op =~ $self->{equality_op} ? 'is' + : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is' + : $op =~ $self->{inequality_op} ? 'is not' + : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not' + : puke "unexpected operator '$orig_op' with undef operand"; + return +{ -op => [ $is.' null', { -ident => $k } ] }; + } + if (!ref($v)) { + return +{ + -op => [ + $self->{cmp}, + { -ident => $k }, + { -bind => [ $k, $v ] } + ] + }; + } + if (ref($v) eq 'HASH' and keys %$v > 1) { + return { -and => [ + map $self->_expand_expr_hashpair($k => { $_ => $v->{$_} }), + sort keys %$v + ] }; + } + if (ref($v) eq 'ARRAY') { + return $self->{sqlfalse} unless @$v; + $self->_debug("ARRAY($k) means distribute over elements"); + my $this_logic = ( + $v->[0] =~ /^-((?:and|or))$/i + ? ($v = [ @{$v}[1..$#$v] ], $1) + : ($self->{logic} || 'or') + ); + return +{ "-${this_logic}" => [ map $self->_expand_expr({ $k => $_ }, $this_logic), @$v ] }; + } + if (my $literal = is_literal_value($v)) { + unless (length $k) { + belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; + return \$literal; + } + my ($sql, @bind) = @$literal; + if ($self->{bindtype} eq 'columns') { + for (@bind) { + if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) { + puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]" + } + } + } + return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] }; + } + } + return { $k => $v }; +} sub _recurse_where { my ($self, $where, $logic) = @_; + my $where_exp = $self->_expand_expr($where, $logic); + # dispatch on appropriate method according to refkind of $where - my $method = $self->_METHOD_FOR_refkind("_where", $where); + my $method = $self->_METHOD_FOR_refkind("_where", $where_exp); - my ($sql, @bind) = $self->$method($where, $logic); + my ($sql, @bind) = $self->$method($where_exp, $logic); # DBIx::Class used to call _recurse_where in scalar context # something else might too... @@ -675,9 +809,10 @@ sub _where_unary_op { my ($self, $op, $rhs) = @_; # top level special ops are illegal in general - # this includes the -ident/-value ops (dual purpose unary and special) puke "Illegal use of top-level '-$op'" - if ! defined $self->{_nested_func_lhs} and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}; + if !(defined $self->{_nested_func_lhs}) + and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}} + and not List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}; if (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { my $handler = $op_entry->{handler}; @@ -817,11 +952,11 @@ sub _where_op_IDENT { } # in case we are called as a top level special op (no '=') - my $lhs = shift; + my $has_lhs = my $lhs = shift; $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs); - return $lhs + return $has_lhs ? "$lhs = $rhs" : $rhs ; @@ -837,7 +972,7 @@ sub _where_op_VALUE { # special-case NULL if (! defined $rhs) { return defined $lhs - ? $self->_convert($self->_quote($lhs)) . ' IS NULL' + ? $self->_where_hashpair_HASHREF($lhs, { -is => undef }) : undef ; } @@ -861,6 +996,41 @@ sub _where_op_VALUE { ; } + +my %unop_postfix = map +($_ => 1), 'is null', 'is not null'; + +sub _where_op_OP { + my ($self, undef, $v) = @_; + my ($op, @args) = @$v; + $op =~ s/^-// if length($op) > 1; + local $self->{_nested_func_lhs}; + if (@args == 1) { + my ($expr_sql, @bind) = $self->_recurse_where($args[0]); + my $final_op = join ' ', split '_', $op; + my $op_sql = $self->_sqlcase($final_op); + my $final_sql = ( + $unop_postfix{lc($final_op)} + ? "${expr_sql} ${op_sql}" + : "${op_sql} ${expr_sql}" + ); + return ($final_sql, @bind); + } elsif (@args == 2) { + my ($l, $r) = map [ $self->_recurse_where($_) ], @args; + return ( $l->[0].' '.$self->_sqlcase(join ' ', split '_', $op).' '.$r->[0], @{$l}[1..$#$l], @{$r}[1..$#$r] ); + } + die "unhandled"; +} + +sub _where_op_BIND { + my ($self, undef, $bind) = @_; + return ($self->_convert('?'), $self->_bindtype(@$bind)); +} + +sub _where_op_LITERAL { + my ($self, undef, $literal) = @_; + return @$literal; +} + sub _where_hashpair_ARRAYREF { my ($self, $k, $v) = @_; @@ -1082,19 +1252,14 @@ sub _where_hashpair_ARRAYREFREF { sub _where_hashpair_SCALAR { my ($self, $k, $v) = @_; $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v"); - my $sql = join ' ', $self->_convert($self->_quote($k)), - $self->_sqlcase($self->{cmp}), - $self->_convert('?'); - my @bind = $self->_bindtype($k, $v); - return ($sql, @bind); + return ($self->_where_hashpair_HASHREF($k, { $self->{cmp} => $v })); } sub _where_hashpair_UNDEF { my ($self, $k, $v) = @_; $self->_debug("UNDEF($k) means IS NULL"); - my $sql = $self->_quote($k) . $self->_sqlcase(' is null'); - return ($sql); + return $self->_where_hashpair_HASHREF($k, { -is => undef }); } #====================================================================== @@ -1200,7 +1365,7 @@ sub _where_field_BETWEEN { sub _where_field_IN { my ($self, $k, $op, $vals) = @_; - # backwards compatibility : if scalar, force into an arrayref + # backwards compatibility: if scalar, force into an arrayref $vals = [$vals] if defined $vals && ! ref $vals; my ($label) = $self->_convert($self->_quote($k)); @@ -1253,7 +1418,7 @@ sub _where_field_IN { $self->_bindtype($k, @all_bind), ); } - else { # empty list : some databases won't understand "IN ()", so DWIM + else { # empty list: some databases won't understand "IN ()", so DWIM my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse}; return ($sql); } @@ -1922,7 +2087,7 @@ Which will change the above C to: WHERE event_date >= '2/13/99' AND event_date <= '4/24/03' The logic can also be changed locally by inserting -a modifier in front of an arrayref : +a modifier in front of an arrayref: @where = (-and => [event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'} ]); @@ -2133,7 +2298,7 @@ L. =head2 select($source, $fields, $where, $order) This returns a SQL SELECT statement and associated list of bind values, as -specified by the arguments : +specified by the arguments: =over @@ -2143,8 +2308,7 @@ Specification of the 'FROM' part of the statement. The argument can be either a plain scalar (interpreted as a table name, will be quoted), or an arrayref (interpreted as a list of table names, joined by commas, quoted), or a scalarref -(literal table name, not quoted), or a ref to an arrayref -(list of literal table names, joined by commas, not quoted). +(literal SQL, not quoted). =item $fields @@ -2498,7 +2662,7 @@ Here is a quick list of equivalencies, since there is some overlap: -=head2 Special operators : IN, BETWEEN, etc. +=head2 Special operators: IN, BETWEEN, etc. You can also use the hashref format to compare a list of fields using the C comparison operator, by specifying the list as an arrayref: @@ -2517,8 +2681,8 @@ The reverse operator C<-not_in> generates SQL C and is used in the same way. If the argument to C<-in> is an empty array, 'sqlfalse' is generated -(by default : C<1=0>). Similarly, C<< -not_in => [] >> generates -'sqltrue' (by default : C<1=1>). +(by default: C<1=0>). Similarly, C<< -not_in => [] >> generates +'sqltrue' (by default: C<1=1>). In addition to the array you can supply a chunk of literal sql or literal sql with bind: @@ -2581,7 +2745,7 @@ Would give you: These are the two builtin "special operators"; but the -list can be expanded : see section L below. +list can be expanded: see section L below. =head2 Unary operators: bool @@ -2645,7 +2809,7 @@ This data structure would create the following: Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or> -to change the logic inside : +to change the logic inside: my @where = ( -and => [ @@ -2669,7 +2833,7 @@ That would yield: C: when connecting several conditions, the C<-and->|C<-or> operator goes C of the nested structure; whereas when connecting several constraints on one column, the C<-and> operator goes -C the arrayref. Here is an example combining both features : +C the arrayref. Here is an example combining both features: my @where = ( -and => [a => 1, b => 2], @@ -2684,20 +2848,20 @@ yielding OR ( e LIKE ? AND e LIKE ? ) ) ) This difference in syntax is unfortunate but must be preserved for -historical reasons. So be careful : the two examples below would +historical reasons. So be careful: the two examples below would seem algebraically equivalent, but they are not { col => [ -and => { -like => 'foo%' }, { -like => '%bar' }, ] } - # yields : WHERE ( ( col LIKE ? AND col LIKE ? ) ) + # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) ) [ -and => { col => { -like => 'foo%' } }, { col => { -like => '%bar' } }, ] - # yields : WHERE ( ( col LIKE ? OR col LIKE ? ) ) + # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) ) =head2 Literal SQL and value type operators @@ -2811,7 +2975,7 @@ example will look like: ) Literal SQL is especially useful for nesting parenthesized clauses in the -main SQL query. Here is a first example : +main SQL query. Here is a first example: my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); @@ -2820,7 +2984,7 @@ main SQL query. Here is a first example : bar => \["IN ($sub_stmt)" => @sub_bind], ); -This yields : +This yields: $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?))"; @@ -2841,7 +3005,7 @@ to C : In the examples above, the subquery was used as an operator on a column; but the same principle also applies for a clause within the main C<%where> -hash, like an EXISTS subquery : +hash, like an EXISTS subquery: my ($sub_stmt, @sub_bind) = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); @@ -2858,7 +3022,7 @@ which yields Observe that the condition on C in the subquery refers to -column C of the main query : this is I a bind +column C of the main query: this is I a bind value, so we have to express it through a scalar ref. Writing C<< c2 => {">" => "t0.c0"} >> would have generated C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly @@ -2993,7 +3157,7 @@ forms. Examples: A "special operator" is a SQL syntactic clause that can be applied to a field, instead of a usual binary operator. -For example : +For example: WHERE field IN (?, ?, ?) WHERE field BETWEEN ? AND ? @@ -3212,7 +3376,7 @@ to clarify the semantics. Hence, client code that was relying on some dark areas of C v1.* B in v1.50. -The main changes are : +The main changes are: =over @@ -3234,7 +3398,7 @@ optional support for L =item * -defensive programming : check arguments +defensive programming: check arguments =item *