X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=1c7ba4d7e6aee70db2c545cf8e4478dc7c3bdf84;hb=422ed2ded5bd4317cc7b41094f012d1dec86f4d1;hp=6dabd39fe2c029dc01fa29bd2bf48fa06d547bfa;hpb=46dc2f3e47d514cd376003cea2df63222c492b0b;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 6dabd39..1c7ba4d 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -10,7 +10,7 @@ use Scalar::Util (); # 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 @@ -24,6 +24,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 @@ -34,7 +35,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' }, ); #====================================================================== @@ -80,9 +81,12 @@ sub new { $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'; @@ -685,6 +689,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}), @@ -755,9 +767,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 @@ -797,9 +817,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"); }, @@ -824,7 +849,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) = @_; @@ -844,27 +884,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')"; } } @@ -1227,10 +1275,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] ) ); } @@ -1815,6 +1864,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