X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FSQL-Abstract.git;a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=692816fa001c279174f941f887ccad971cd329af;hp=5cdc47f9088cc9b2493c84da807daee3640e5149;hb=1f490ae449fd0c9dc413b776cbc77557f79d6ab5;hpb=40f2f2311d048aece00793477ab4b734d20f57bc diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 5cdc47f..692816f 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -6,11 +6,28 @@ 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; + } + + *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} + ? sub () { 0 } + : sub () { 1 } + ; +} + #====================================================================== # GLOBALS #====================================================================== -our $VERSION = '1.75'; +our $VERSION = '1.78'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -58,6 +75,69 @@ 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 + ( + # 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 or boolification, AND fallback is *not* disabled + ( + SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION + and + ( + grep { *{"${_}::(0+"}{CODE} } @{$_[2]} + or + grep { *{"${_}::(bool"}{CODE} } @{$_[2]} + ) + and + ( + # no fallback specified at all + ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} ) + or + # fallback explicitly undef + ! defined ${"$_[3]::()"} + or + # explicitly true + !! ${"$_[3]::()"} + ) + ) + ) + ) ? \($_[0]) + : undef; +} + + #====================================================================== # NEW @@ -417,9 +497,15 @@ sub _recurse_where { my ($sql, @bind) = $self->$method($where, $logic); - # DBIx::Class directly calls _recurse_where in scalar context, so - # we must implement it, even if not in the official API - return wantarray ? ($sql, @bind) : $sql; + # DBIx::Class used to call _recurse_where in scalar context + # something else might too... + if (wantarray) { + return ($sql, @bind); + } + else { + belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0"; + return $sql; + } } @@ -667,8 +753,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 '=') @@ -689,6 +775,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}), @@ -765,6 +859,11 @@ sub _where_hashpair_HASHREF { # 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 @@ -1262,10 +1361,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] ) ); } @@ -1624,7 +1724,7 @@ say something like this: my %data = ( name => 'Bill', - date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"], + date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ], ); The first value in the array is the actual SQL. Any other values are @@ -1676,16 +1776,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 @@ -1828,7 +1925,7 @@ are or are not included. You could wrap that above C loop in a simple sub called C or something and reuse it repeatedly. You still get a layer of abstraction over manual SQL specification. -Note that if you set L to C, the C<\[$sql, @bind]> +Note that if you set L to C, the C<\[ $sql, @bind ]> construct (see L) will expect the bind values in this format. @@ -1850,6 +1947,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 @@ -2032,6 +2144,88 @@ 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 B reference +to the original supplied argument. + +=over + +=item * Note + +The stringification overloading detection is rather advanced: it takes +into consideration not only the presence of a C<""> overload, but if that +fails also checks for enabled +L|overload/Magic Autogeneration>, based +on either C<0+> or C. + +Unfortunately testing in the field indicates that this +detection B<< may tickle a latent bug in perl versions before 5.018 >>, +but only when very large numbers of stringifying objects are involved. +At the time of writing ( Sep 2014 ) there is no clear explanation of +the direct cause, nor is there a manageably small test case that reliably +reproduces the problem. + +If you encounter any of the following exceptions in B - this module may be to blame: + + Operation "ne": no method found, + left argument in overloaded package , + right argument in overloaded package + +or perhaps even + + Stub found while resolving method "???" overloading """" in package + +If you fall victim to the above - please attempt to reduce the problem +to something that could be sent to the L +(either publicly or privately). As a workaround in the meantime you can +set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true +value, which will most likely eliminate your problem (at the expense of +not being able to properly detect exotic forms of stringification). + +This notice and environment variable will be removed in a future version, +as soon as the underlying problem is found and a reliable workaround is +devised. + +=back + +=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 an B reference +containing the unpacked version of the supplied literal SQL and bind values. + =head1 WHERE CLAUSES =head2 Introduction @@ -2495,7 +2689,7 @@ not so common, but perfectly legal Perl). For example, to find a date in Postgres you can use something like this: my %where = ( - date_column => \[q/= date '2008-09-30' - ?::integer/, 10/] + date_column => \[ "= date '2008-09-30' - ?::integer", 10 ] ) This would create: @@ -2504,15 +2698,16 @@ This would create: @bind = ('10'); Note that you must pass the bind values in the same format as they are returned -by L. That means that if you set L to C, you must -provide the bind values in the C<< [ column_meta => value ] >> format, where -C is an opaque scalar value; most commonly the column name, but -you can use any scalar value (including references and blessed references), -L will simply pass it through intact. So if C is set -to C the above example will look like: +by L. This means that if you set L +to C, you must provide the bind values in the +C<< [ column_meta => value ] >> format, where C is an opaque +scalar value; most commonly the column name, but you can use any scalar value +(including references and blessed references), L will simply +pass it through intact. So if C is set to C the above +example will look like: my %where = ( - date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/] + date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ] ) Literal SQL is especially useful for nesting parenthesized clauses in the @@ -2903,7 +3098,7 @@ The main changes are : =item * -support for literal SQL through the C<< \ [$sql, bind] >> syntax. +support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax. =item *