X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=54408dfce437cbeb76478bddbc3cc3eae20ea2a5;hb=8aa76984c08d55d3a4e37ce4fde6c9f7169e2e6e;hp=2bc89ebddb577fbe568442e6207798f33d7010ba;hpb=ff8ca6b4ad42a4b4d7adbfc89c820b48e2dd52c0;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 2bc89eb..54408df 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -1,21 +1,28 @@ package SQL::Abstract; # see doc at end of file -# LDNOTE : this code is heavy refactoring from original SQLA. -# Several design decisions will need discussion during -# the test / diffusion / acceptance phase; those are marked with flag -# 'LDNOTE' (note by laurent.dami AT free.fr) - use strict; use warnings; use Carp (); use List::Util (); use Scalar::Util (); +use Exporter 'import'; +our @EXPORT_OK = qw(is_plain_value is_literal_value); + +BEGIN { + if ($] < 5.009_005) { + require MRO::Compat; + } + else { + require mro; + } +} + #====================================================================== # GLOBALS #====================================================================== -our $VERSION = '1.74'; +our $VERSION = '1.78'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -29,6 +36,7 @@ my @BUILTIN_SPECIAL_OPS = ( {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'}, {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'}, {regex => qr/^ value $/ix, handler => '_where_op_VALUE'}, + {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'}, ); # unaryish operators - key maps to handler @@ -39,7 +47,7 @@ my @BUILTIN_UNARY_OPS = ( { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' }, { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' }, { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' }, - { regex => qr/^ value $/ix, handler => '_where_op_VALUE' }, + { regex => qr/^ value $/xi, handler => '_where_op_VALUE' }, ); #====================================================================== @@ -62,6 +70,65 @@ sub puke (@) { Carp::croak "[$func] Fatal: ", @_; } +sub is_literal_value ($) { + ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ] + : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ] + : ( + ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 + and + defined $_[0]->{-ident} and ! length ref $_[0]->{-ident} + ) ? [ $_[0]->{-ident} ] + : undef; +} + +# FIXME XSify - this can be done so much more efficiently +sub is_plain_value ($) { + no strict 'refs'; + ! length ref $_[0] ? [ $_[0] ] + : ( + ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 + and + exists $_[0]->{-value} + ) ? [ $_[0]->{-value} ] + : ( + Scalar::Util::blessed $_[0] + and + # deliberately not using Devel::OverloadInfo - the checks we are + # intersted in are much more limited than the fullblown thing, and + # this is a very hot piece of code + ( + # FIXME - DBI needs fixing to stringify regardless of DBD + # + # simply using ->can('(""') can leave behind stub methods that + # break actually using the overload later (see L and the source of overload::mycan()) + # + # either has stringification which DBI SHOULD prefer out of the box + grep { *{ (qq[${_}::(""]) }{CODE} } @{ mro::get_linear_isa( ref $_[0] ) } + or + # has nummification and fallback is *not* disabled + # reuse @_ for even moar speedz + ( + grep { *{"${_}::(0+"}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) } + and + ( + # no fallback specified at all + ! ( ($_[1]) = grep { *{"${_}::()"}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) } ) + or + # fallback explicitly undef + ! defined ${"$_[1]::()"} + or + # explicitly true + ${"$_[1]::()"} + ) + ) + ) + ) ? [ "$_[0]" ] + : undef; +} + + #====================================================================== # NEW @@ -79,17 +146,18 @@ sub new { $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR'; # how to return bind vars - # LDNOTE: changed nwiger code : why this 'delete' ?? - # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal'; $opt{bindtype} ||= 'normal'; # default comparison is "=", but can be overridden $opt{cmp} ||= '='; # try to recognize which are the 'equality' and 'inequality' ops - # (temporary quickfix, should go through a more seasoned API) - $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i; - $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i; + # (temporary quickfix (in 2007), should go through a more seasoned API) + $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix; + $opt{inequality_op} = qr/^( != | <> )$/ix; + + $opt{like_op} = qr/^ (is\s+)? r?like $/xi; + $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi; # SQL booleans $opt{sqltrue} ||= '1=1'; @@ -457,11 +525,6 @@ sub _where_ARRAYREF { }, HASHREF => sub {$self->_recurse_where($el, 'and') if %$el}, - # LDNOTE : previous SQLA code for hashrefs was creating a dirty - # side-effect: the first hashref within an array would change - # the global logic to 'AND'. So [ {cond1, cond2}, [cond3, cond4] ] - # was interpreted as "(cond1 AND cond2) OR (cond3 AND cond4)", - # whereas it should be "(cond1 AND cond2) OR (cond3 OR cond4)". SCALARREF => sub { ($$el); }, @@ -675,8 +738,8 @@ sub _where_op_BOOL { sub _where_op_IDENT { my $self = shift; my ($op, $rhs) = splice @_, -2; - if (ref $rhs) { - puke "-$op takes a single scalar argument (a quotable identifier)"; + if (! defined $rhs or length ref $rhs) { + puke "-$op requires a single plain scalar argument (a quotable identifier)"; } # in case we are called as a top level special op (no '=') @@ -697,6 +760,14 @@ sub _where_op_VALUE { # in case we are called as a top level special op (no '=') my $lhs = shift; + # special-case NULL + if (! defined $rhs) { + return $lhs + ? $self->_convert($self->_quote($lhs)) . ' IS NULL' + : undef + ; + } + my @bind = $self->_bindtype ( ($lhs || $self->{_nested_func_lhs}), @@ -741,7 +812,6 @@ sub _where_hashpair_ARRAYREF { return $self->_recurse_where(\@distributed, $logic); } else { - # LDNOTE : not sure of this one. What does "distribute over nothing" mean? $self->_debug("empty ARRAY($k) means 0=1"); return ($self->{sqlfalse}); } @@ -768,9 +838,17 @@ sub _where_hashpair_HASHREF { $self->_assert_pass_injection_guard($op); + # fixup is_not + $op =~ s/^is_not/IS NOT/i; + # so that -not_foo works correctly $op =~ s/^not_/NOT /i; + # another retarded special case: foo => { $op => { -value => undef } } + if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) { + $val = undef; + } + my ($sql, @bind); # CASE: col-value logic modifiers @@ -810,9 +888,14 @@ sub _where_hashpair_HASHREF { }, UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL" - my $is = ($op =~ $self->{equality_op}) ? 'is' : - ($op =~ $self->{inequality_op}) ? 'is not' : - puke "unexpected operator '$orig_op' with undef operand"; + 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"; + $sql = $self->_quote($k) . $self->_sqlcase(" $is null"); }, @@ -837,7 +920,22 @@ sub _where_hashpair_HASHREF { return ($all_sql, @all_bind); } +sub _where_field_IS { + my ($self, $k, $op, $v) = @_; + my ($s) = $self->_SWITCH_refkind($v, { + UNDEF => sub { + join ' ', + $self->_convert($self->_quote($k)), + map { $self->_sqlcase($_)} ($op, 'null') + }, + FALLBACK => sub { + puke "$op can only take undef as argument"; + }, + }); + + $s; +} sub _where_field_op_ARRAYREF { my ($self, $k, $op, $vals) = @_; @@ -857,27 +955,35 @@ sub _where_field_op_ARRAYREF { shift @vals; } + # a long standing API wart - an attempt to change this behavior during + # the 1.50 series failed *spectacularly*. Warn instead and leave the + # behavior as is + if ( + @vals > 1 + and + (!$logic or $logic eq 'OR') + and + ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} ) + ) { + my $o = uc($op); + belch "A multi-element arrayref as an argument to the inequality op '$o' " + . 'is technically equivalent to an always-true 1=1 (you probably wanted ' + . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)" + ; + } + # distribute $op over each remaining member of @vals, append logic if exists return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic); - # LDNOTE : had planned to change the distribution logic when - # $op =~ $self->{inequality_op}, because of Morgan laws : - # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate - # WHERE field != 22 OR field != 33 : the user probably means - # WHERE field != 22 AND field != 33. - # To do this, replace the above to roughly : - # my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR'; - # return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic); - } else { # try to DWIM on equality operators - # LDNOTE : not 100% sure this is the correct thing to do ... - return ($self->{sqlfalse}) if $op =~ $self->{equality_op}; - return ($self->{sqltrue}) if $op =~ $self->{inequality_op}; - - # otherwise - puke "operator '$op' applied on an empty array (field '$k')"; + return + $op =~ $self->{equality_op} ? $self->{sqlfalse} + : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse} + : $op =~ $self->{inequality_op} ? $self->{sqltrue} + : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue} + : puke "operator '$op' applied on an empty array (field '$k')"; } } @@ -961,6 +1067,8 @@ sub _where_field_BETWEEN { $placeholder = $self->_convert('?'); $op = $self->_sqlcase($op); + my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"; + my ($clause, @bind) = $self->_SWITCH_refkind($vals, { ARRAYREFREF => sub { my ($s, @b) = @$$vals; @@ -971,8 +1079,7 @@ sub _where_field_BETWEEN { return $$vals; }, ARRAYREF => sub { - puke "special op 'between' accepts an arrayref with exactly two values" - if @$vals != 2; + puke $invalid_args if @$vals != 2; my (@all_sql, @all_bind); foreach my $val (@$vals) { @@ -994,7 +1101,10 @@ sub _where_field_BETWEEN { if (@rest or $func !~ /^ \- (.+)/x); local $self->{_nested_func_lhs} = $k; $self->_where_unary_op ($1 => $arg); - } + }, + FALLBACK => sub { + puke $invalid_args, + }, }); push @all_sql, $sql; push @all_bind, @bind; @@ -1006,7 +1116,7 @@ sub _where_field_BETWEEN { ); }, FALLBACK => sub { - puke "special op 'between' accepts an arrayref with two values, or a single literal scalarref/arrayref-ref"; + puke $invalid_args, }, }); @@ -1236,10 +1346,11 @@ sub _quote { else { puke "Unsupported quote_char format: $_[0]->{quote_char}"; } + my $esc = $_[0]->{escape_char} || $r; # parts containing * are naturally unquoted return join( $_[0]->{name_sep}||'', map - { $_ eq '*' ? $_ : $l . $_ . $r } + { $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } } ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] ) ); } @@ -1248,16 +1359,6 @@ sub _quote { # Conversion, if applicable sub _convert ($) { #my ($self, $arg) = @_; - -# LDNOTE : modified the previous implementation below because -# it was not consistent : the first "return" is always an array, -# the second "return" is context-dependent. Anyway, _convert -# seems always used with just a single argument, so make it a -# scalar function. -# return @_ unless $self->{convert}; -# my $conv = $self->_sqlcase($self->{convert}); -# my @ret = map { $conv.'('.$_.')' } @_; -# return wantarray ? @ret : $ret[0]; if ($_[0]->{convert}) { return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')'; } @@ -1267,11 +1368,6 @@ sub _convert ($) { # And bindtype sub _bindtype (@) { #my ($self, $col, @vals) = @_; - - #LDNOTE : changed original implementation below because it did not make - # sense when bindtype eq 'columns' and @vals > 1. -# return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals; - # called often - tighten code return $_[0]->{bindtype} eq 'columns' ? map {[$_[1], $_]} @_[2 .. $#_] @@ -1665,16 +1761,13 @@ Which you could then use in DBI code like so: Easy, eh? -=head1 FUNCTIONS +=head1 METHODS -The functions are simple. There's one for each major SQL operation, +The methods are simple. There's one for each major SQL operation, and a constructor you use first. The arguments are specified in a -similar order to each function (table, then fields, then a where +similar order to each method (table, then fields, then a where clause) to try and simplify things. - - - =head2 new(option => 'value') The C function takes a list of options and values, and returns @@ -1839,6 +1932,21 @@ that generates SQL like this: Quoting is useful if you have tables or columns names that are reserved words in your database's SQL dialect. +=item escape_char + +This is the character that will be used to escape Ls appearing +in an identifier before it has been quoted. + +The paramter default in case of a single L character is the quote +character itself. + +When opening-closing-style quoting is used (L is an arrayref) +this parameter defaults to the B L. Occurences +of the B L within the identifier are currently left +untouched. The default for opening-closing-style quotes may change in future +versions, thus you are B to specify the escape character +explicitly. + =item name_sep This is the character that separates a table and column name. It is @@ -2021,6 +2129,47 @@ Might give you: You get the idea. Strings get their case twiddled, but everything else remains verbatim. +=head1 EXPORTABLE FUNCTIONS + +=head2 is_plain_value + +Determines if the supplied argument is a plain value as understood by this +module: + +=over + +=item * The value is C + +=item * The value is a non-reference + +=item * The value is an object with stringification overloading + +=item * The value is of the form C<< { -value => $anything } >> + +=back + +On failure returns C, on sucess returns a reference to a single +element array containing the string-version of the supplied argument or +C<[ undef ]> in case of an undefined initial argument. + +=head2 is_literal_value + +Determines if the supplied argument is a literal value as understood by this +module: + +=over + +=item * C<\$sql_string> + +=item * C<\[ $sql_string, @bind_values ]> + +=item * C<< { -ident => $plain_defined_string } >> + +=back + +On failure returns C, on sucess returns a reference to an array +cotaining the unpacked version of the supplied literal SQL and bind values. + =head1 WHERE CLAUSES =head2 Introduction @@ -2306,15 +2455,19 @@ then you should use the and/or operators:- my %where = ( -and => [ -bool => 'one', - -bool => 'two', - -bool => 'three', - -not_bool => 'four', + -not_bool => { two=> { -rlike => 'bar' } }, + -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] }, ], ); Would give you: - WHERE one AND two AND three AND NOT four + WHERE + one + AND + (NOT two RLIKE ?) + AND + (NOT ( three = ? OR three > ? )) =head2 Nested conditions, -and/-or prefixes @@ -2837,6 +2990,9 @@ can be as simple as the following: #!/usr/bin/perl + use warnings; + use strict; + use CGI::FormBuilder; use SQL::Abstract;