X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=0c3f11c03f5fd4bf8df85de1c5f4d4897003aac6;hb=d0ecdb28a6c6ba2112bf49e3fa687ee989353a9f;hp=6e6bd5a4f815072b1d9be05d85fec7b7ab8cddd2;hpb=3cdadcbe32e98b018af5bca2d8270b13d2d2a77a;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 6e6bd5a..0c3f11c 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -6,11 +6,23 @@ 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 @@ -24,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 @@ -34,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' }, ); #====================================================================== @@ -57,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} ] + : ( + # reuse @_ for even moar speedz + defined ( $_[1] = 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} } @{ $_[2] = mro::get_linear_isa( $_[1] ) } + or + # has nummification and fallback is *not* disabled + ( + grep { *{"${_}::(0+"}{CODE} } @{ mro::get_linear_isa( $_[1] ) } + and + ( + # no fallback specified at all + ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} ) + or + # fallback explicitly undef + ! defined ${"$_[3]::()"} + or + # explicitly true + !! ${"$_[3]::()"} + ) + ) + ) + ) ? [ $_[0] ] + : undef; +} + + #====================================================================== # NEW @@ -666,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 '=') @@ -688,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}), @@ -758,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 @@ -801,7 +889,8 @@ sub _where_hashpair_HASHREF { UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL" my $is = - $op =~ $self->{equality_op} ? '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' @@ -831,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) = @_; @@ -1242,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] ) ); } @@ -1656,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 @@ -1830,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 @@ -2012,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