From: Peter Rabbitson Date: Thu, 17 Jul 2014 09:23:53 +0000 (+0200) Subject: New exportable functions: is_literal_value($) and is_plain_value($) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0da0fe34ca9d452d6775777f691b100a28d98907;p=scpubgit%2FQ-Branch.git New exportable functions: is_literal_value($) and is_plain_value($) Ported from DBIC with some corner case fixes added. --- diff --git a/Changes b/Changes index e2935f9..c154cdc 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,6 @@ Revision history for SQL::Abstract + - New exportable functions: is_literal_value($) and is_plain_value($) - New attribute 'escape_char' allowing for proper escape of quote_chars present in an identifier - Treat { -value => undef } as plain undef in all cases diff --git a/Makefile.PL b/Makefile.PL index 66b4022..b26b78f 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,6 +17,7 @@ dynamic_config 0; requires 'List::Util' => 0; requires 'Scalar::Util' => 0; +requires 'Exporter' => 5.57; requires 'Moo' => 1.004002; requires 'Hash::Merge' => 0.12; diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 1c7ba4d..ce4ead9 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -6,6 +6,18 @@ 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 #====================================================================== @@ -58,6 +70,60 @@ 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 + # + # either has stringification which DBI SHOULD prefer out of the box + $_[0]->can( '(""' ) + or + # has nummification and fallback is *not* disabled + # reuse @_ for even moar speedz + ( + $_[0]->can('(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 @@ -1690,16 +1756,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 @@ -2061,6 +2124,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 diff --git a/t/23_is_X_value.t b/t/23_is_X_value.t new file mode 100644 index 0000000..b919e0a --- /dev/null +++ b/t/23_is_X_value.t @@ -0,0 +1,111 @@ +use warnings; +use strict; + +use Test::More; +use Test::Exception; + +use SQL::Abstract qw(is_plain_value is_literal_value); + +{ + package # hideee + SQLATest::SillyInt; + + use overload + # *DELIBERATELY* unspecified + #fallback => 1, + '0+' => sub { ${$_[0]} }, + ; + + package # hideee + SQLATest::SillyInt::Subclass; + + our @ISA = 'SQLATest::SillyInt'; +} + +{ + package # hideee + SQLATest::SillierInt; + + use overload + fallback => 0, + ; + + package # hideee + SQLATest::SillierInt::Subclass; + + use overload + '0+' => sub { ${$_[0]} }, + '+' => sub { ${$_[0]} + $_[1] }, + ; + + our @ISA = 'SQLATest::SillierInt'; +} + +# make sure we recognize overloaded stuff properly +lives_ok { + my $num = bless( \do { my $foo = 69 }, 'SQLATest::SillyInt::Subclass' ); + ok( is_plain_value $num, 'parent-fallback-provided stringification detected' ); + is("$num", 69, 'test overloaded object stringifies, without specified fallback'); +} 'overload testing lives'; + +{ + my $nummifiable_maybefallback_num = bless( \do { my $foo = 42 }, 'SQLATest::SillierInt::Subclass' ); + lives_ok { + ok( ( $nummifiable_maybefallback_num + 1) == 43 ) + }; + + my $can_str = !! eval { "$nummifiable_maybefallback_num" }; + + lives_ok { + is_deeply( + is_plain_value $nummifiable_maybefallback_num, + ( $can_str ? [ 42 ] : undef ), + 'parent-disabled-fallback stringification detected same as perl', + ); + }; +} + +is_deeply + is_plain_value { -value => [] }, + [ [] ], + '-value recognized' +; + +for ([], {}, \'') { + is + is_plain_value $_, + undef, + 'nonvalues correctly recognized' + ; +} + +for (undef, { -value => undef }) { + is_deeply + is_plain_value $_, + [ undef ], + 'NULL -value recognized' + ; +} + +is_deeply + is_literal_value { -ident => 'foo' }, + [ 'foo' ], + '-ident recognized as literal' +; + +is_deeply + is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ], + [ 'sql', 'bind1', [ {} => 'bind2' ] ], + 'literal correctly unpacked' +; + + +for ([], {}, \'', undef) { + is + is_literal_value { -ident => $_ }, + undef, + 'illegal -ident does not trip up detection' + ; +} + +done_testing;