| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package SQL::Abstract; # see doc at end of file | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 14 |  |  | 14 |  | 311923 | use strict; | 
|  | 14 |  |  |  |  | 73 |  | 
|  | 14 |  |  |  |  | 383 |  | 
| 4 | 14 |  |  | 14 |  | 65 | use warnings; | 
|  | 14 |  |  |  |  | 27 |  | 
|  | 14 |  |  |  |  | 313 |  | 
| 5 | 14 |  |  | 14 |  | 60 | use Carp (); | 
|  | 14 |  |  |  |  | 22 |  | 
|  | 14 |  |  |  |  | 223 |  | 
| 6 | 14 |  |  | 14 |  | 71 | use List::Util (); | 
|  | 14 |  |  |  |  | 22 |  | 
|  | 14 |  |  |  |  | 196 |  | 
| 7 | 14 |  |  | 14 |  | 60 | use Scalar::Util (); | 
|  | 14 |  |  |  |  | 21 |  | 
|  | 14 |  |  |  |  | 251 |  | 
| 8 |  |  |  |  |  |  |  | 
| 9 | 14 |  |  | 14 |  | 59 | use Exporter 'import'; | 
|  | 14 |  |  |  |  | 21 |  | 
|  | 14 |  |  |  |  | 1508 |  | 
| 10 |  |  |  |  |  |  | our @EXPORT_OK = qw(is_plain_value is_literal_value); | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  | BEGIN { | 
| 13 | 14 | 50 |  | 14 |  | 73 | if ($] < 5.009_005) { | 
| 14 | 0 |  |  |  |  | 0 | require MRO::Compat; | 
| 15 |  |  |  |  |  |  | } | 
| 16 |  |  |  |  |  |  | else { | 
| 17 | 14 |  |  |  |  | 64 | require mro; | 
| 18 |  |  |  |  |  |  | } | 
| 19 |  |  |  |  |  |  |  | 
| 20 |  |  |  |  |  |  | *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} | 
| 21 |  |  |  |  |  |  | ? sub () { 0 } | 
| 22 |  |  |  |  |  |  | : sub () { 1 } | 
| 23 | 14 | 50 |  |  |  | 6494 | ; | 
| 24 |  |  |  |  |  |  | } | 
| 25 |  |  |  |  |  |  |  | 
| 26 |  |  |  |  |  |  | #====================================================================== | 
| 27 |  |  |  |  |  |  | # GLOBALS | 
| 28 |  |  |  |  |  |  | #====================================================================== | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | our $VERSION  = '1.86'; | 
| 31 |  |  |  |  |  |  |  | 
| 32 |  |  |  |  |  |  | # This would confuse some packagers | 
| 33 |  |  |  |  |  |  | $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases | 
| 34 |  |  |  |  |  |  |  | 
| 35 |  |  |  |  |  |  | our $AUTOLOAD; | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | # special operators (-in, -between). May be extended/overridden by user. | 
| 38 |  |  |  |  |  |  | # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation | 
| 39 |  |  |  |  |  |  | my @BUILTIN_SPECIAL_OPS = ( | 
| 40 |  |  |  |  |  |  | {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'}, | 
| 41 |  |  |  |  |  |  | {regex => qr/^ (?: not \s )? in      $/ix, handler => '_where_field_IN'}, | 
| 42 |  |  |  |  |  |  | {regex => qr/^ ident                 $/ix, handler => '_where_op_IDENT'}, | 
| 43 |  |  |  |  |  |  | {regex => qr/^ value                 $/ix, handler => '_where_op_VALUE'}, | 
| 44 |  |  |  |  |  |  | {regex => qr/^ is (?: \s+ not )?     $/ix, handler => '_where_field_IS'}, | 
| 45 |  |  |  |  |  |  | ); | 
| 46 |  |  |  |  |  |  |  | 
| 47 |  |  |  |  |  |  | # unaryish operators - key maps to handler | 
| 48 |  |  |  |  |  |  | my @BUILTIN_UNARY_OPS = ( | 
| 49 |  |  |  |  |  |  | # the digits are backcompat stuff | 
| 50 |  |  |  |  |  |  | { regex => qr/^ and  (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' }, | 
| 51 |  |  |  |  |  |  | { regex => qr/^ or   (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' }, | 
| 52 |  |  |  |  |  |  | { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' }, | 
| 53 |  |  |  |  |  |  | { regex => qr/^ (?: not \s )? bool     $/xi, handler => '_where_op_BOOL' }, | 
| 54 |  |  |  |  |  |  | { regex => qr/^ ident                  $/xi, handler => '_where_op_IDENT' }, | 
| 55 |  |  |  |  |  |  | { regex => qr/^ value                  $/xi, handler => '_where_op_VALUE' }, | 
| 56 |  |  |  |  |  |  | ); | 
| 57 |  |  |  |  |  |  |  | 
| 58 |  |  |  |  |  |  | #====================================================================== | 
| 59 |  |  |  |  |  |  | # DEBUGGING AND ERROR REPORTING | 
| 60 |  |  |  |  |  |  | #====================================================================== | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | sub _debug { | 
| 63 | 1160 | 50 |  | 1160 |  | 2205 | return unless $_[0]->{debug}; shift; # a little faster | 
|  | 0 |  |  |  |  | 0 |  | 
| 64 | 0 |  |  |  |  | 0 | my $func = (caller(1))[3]; | 
| 65 | 0 |  |  |  |  | 0 | warn "[$func] ", @_, "\n"; | 
| 66 |  |  |  |  |  |  | } | 
| 67 |  |  |  |  |  |  |  | 
| 68 |  |  |  |  |  |  | sub belch (@) { | 
| 69 | 148 |  |  | 148 | 0 | 466 | my($func) = (caller(1))[3]; | 
| 70 | 148 |  |  |  |  | 7259 | Carp::carp "[$func] Warning: ", @_; | 
| 71 |  |  |  |  |  |  | } | 
| 72 |  |  |  |  |  |  |  | 
| 73 |  |  |  |  |  |  | sub puke (@) { | 
| 74 | 116 |  |  | 116 | 0 | 341 | my($func) = (caller(1))[3]; | 
| 75 | 116 |  |  |  |  | 4862 | Carp::croak "[$func] Fatal: ", @_; | 
| 76 |  |  |  |  |  |  | } | 
| 77 |  |  |  |  |  |  |  | 
| 78 |  |  |  |  |  |  | sub is_literal_value ($) { | 
| 79 | 13 |  |  |  |  | 42 | ref $_[0] eq 'SCALAR'                                     ? [ ${$_[0]} ] | 
| 80 | 50 | 100 | 66 | 50 | 1 | 1490 | : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' )        ? [ @${ $_[0] } ] | 
|  | 9 | 100 |  |  |  | 27 |  | 
| 81 |  |  |  |  |  |  | : undef; | 
| 82 |  |  |  |  |  |  | } | 
| 83 |  |  |  |  |  |  |  | 
| 84 |  |  |  |  |  |  | # FIXME XSify - this can be done so much more efficiently | 
| 85 |  |  |  |  |  |  | sub is_plain_value ($) { | 
| 86 | 14 |  |  | 14 |  | 90 | no strict 'refs'; | 
|  | 14 |  |  |  |  | 43 |  | 
|  | 14 |  |  |  |  | 118342 |  | 
| 87 |  |  |  |  |  |  | ! length ref $_[0]                                        ? \($_[0]) | 
| 88 |  |  |  |  |  |  | : ( | 
| 89 |  |  |  |  |  |  | ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 | 
| 90 |  |  |  |  |  |  | and | 
| 91 |  |  |  |  |  |  | exists $_[0]->{-value} | 
| 92 |  |  |  |  |  |  | )                                                           ? \($_[0]->{-value}) | 
| 93 |  |  |  |  |  |  | : ( | 
| 94 |  |  |  |  |  |  | # reuse @_ for even moar speedz | 
| 95 |  |  |  |  |  |  | defined ( $_[1] = Scalar::Util::blessed $_[0] ) | 
| 96 |  |  |  |  |  |  | and | 
| 97 |  |  |  |  |  |  | # deliberately not using Devel::OverloadInfo - the checks we are | 
| 98 |  |  |  |  |  |  | # intersted in are much more limited than the fullblown thing, and | 
| 99 |  |  |  |  |  |  | # this is a very hot piece of code | 
| 100 |  |  |  |  |  |  | ( | 
| 101 |  |  |  |  |  |  | # simply using ->can('(""') can leave behind stub methods that | 
| 102 |  |  |  |  |  |  | # break actually using the overload later (see L | 
| 103 |  |  |  |  |  |  | # found while resolving method "%s" overloading "%s" in package | 
| 104 |  |  |  |  |  |  | # "%s"> and the source of overload::mycan()) | 
| 105 |  |  |  |  |  |  | # | 
| 106 |  |  |  |  |  |  | # either has stringification which DBI SHOULD prefer out of the box | 
| 107 |  |  |  |  |  |  | grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) } | 
| 108 |  |  |  |  |  |  | or | 
| 109 |  |  |  |  |  |  | # has nummification or boolification, AND fallback is *not* disabled | 
| 110 |  |  |  |  |  |  | ( | 
| 111 |  |  |  |  |  |  | SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION | 
| 112 |  |  |  |  |  |  | and | 
| 113 |  |  |  |  |  |  | ( | 
| 114 |  |  |  |  |  |  | grep { *{"${_}::(0+"}{CODE} } @{$_[2]} | 
| 115 |  |  |  |  |  |  | or | 
| 116 |  |  |  |  |  |  | grep { *{"${_}::(bool"}{CODE} } @{$_[2]} | 
| 117 |  |  |  |  |  |  | ) | 
| 118 |  |  |  |  |  |  | and | 
| 119 |  |  |  |  |  |  | ( | 
| 120 |  |  |  |  |  |  | # no fallback specified at all | 
| 121 |  |  |  |  |  |  | ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} ) | 
| 122 |  |  |  |  |  |  | or | 
| 123 |  |  |  |  |  |  | # fallback explicitly undef | 
| 124 |  |  |  |  |  |  | ! defined ${"$_[3]::()"} | 
| 125 |  |  |  |  |  |  | or | 
| 126 |  |  |  |  |  |  | # explicitly true | 
| 127 | 47 | 100 | 66 | 47 | 1 | 19013 | !! ${"$_[3]::()"} | 
|  |  | 100 | 100 |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 128 |  |  |  |  |  |  | ) | 
| 129 |  |  |  |  |  |  | ) | 
| 130 |  |  |  |  |  |  | ) | 
| 131 |  |  |  |  |  |  | )                                                          ? \($_[0]) | 
| 132 |  |  |  |  |  |  | : undef; | 
| 133 |  |  |  |  |  |  | } | 
| 134 |  |  |  |  |  |  |  | 
| 135 |  |  |  |  |  |  |  | 
| 136 |  |  |  |  |  |  |  | 
| 137 |  |  |  |  |  |  | #====================================================================== | 
| 138 |  |  |  |  |  |  | # NEW | 
| 139 |  |  |  |  |  |  | #====================================================================== | 
| 140 |  |  |  |  |  |  |  | 
| 141 |  |  |  |  |  |  | sub new { | 
| 142 | 611 |  |  | 611 | 1 | 8534 | my $self = shift; | 
| 143 | 611 |  | 33 |  |  | 1934 | my $class = ref($self) || $self; | 
| 144 | 611 | 100 |  |  |  | 1882 | my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; | 
|  | 101 |  |  |  |  | 282 |  | 
| 145 |  |  |  |  |  |  |  | 
| 146 |  |  |  |  |  |  | # choose our case by keeping an option around | 
| 147 | 611 | 100 | 100 |  |  | 1428 | delete $opt{case} if $opt{case} && $opt{case} ne 'lower'; | 
| 148 |  |  |  |  |  |  |  | 
| 149 |  |  |  |  |  |  | # default logic for interpreting arrayrefs | 
| 150 | 611 | 100 |  |  |  | 1261 | $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR'; | 
| 151 |  |  |  |  |  |  |  | 
| 152 |  |  |  |  |  |  | # how to return bind vars | 
| 153 | 611 |  | 100 |  |  | 1964 | $opt{bindtype} ||= 'normal'; | 
| 154 |  |  |  |  |  |  |  | 
| 155 |  |  |  |  |  |  | # default comparison is "=", but can be overridden | 
| 156 | 611 |  | 100 |  |  | 1786 | $opt{cmp} ||= '='; | 
| 157 |  |  |  |  |  |  |  | 
| 158 |  |  |  |  |  |  | # try to recognize which are the 'equality' and 'inequality' ops | 
| 159 |  |  |  |  |  |  | # (temporary quickfix (in 2007), should go through a more seasoned API) | 
| 160 | 611 |  |  |  |  | 3265 | $opt{equality_op}   = qr/^( \Q$opt{cmp}\E | \= )$/ix; | 
| 161 | 611 |  |  |  |  | 1414 | $opt{inequality_op} = qr/^( != | <> )$/ix; | 
| 162 |  |  |  |  |  |  |  | 
| 163 | 611 |  |  |  |  | 1268 | $opt{like_op}       = qr/^ (is\s+)? r?like $/xi; | 
| 164 | 611 |  |  |  |  | 1065 | $opt{not_like_op}   = qr/^ (is\s+)? not \s+ r?like $/xi; | 
| 165 |  |  |  |  |  |  |  | 
| 166 |  |  |  |  |  |  | # SQL booleans | 
| 167 | 611 |  | 50 |  |  | 2142 | $opt{sqltrue}  ||= '1=1'; | 
| 168 | 611 |  | 50 |  |  | 1876 | $opt{sqlfalse} ||= '0=1'; | 
| 169 |  |  |  |  |  |  |  | 
| 170 |  |  |  |  |  |  | # special operators | 
| 171 | 611 |  | 100 |  |  | 1971 | $opt{special_ops} ||= []; | 
| 172 |  |  |  |  |  |  | # regexes are applied in order, thus push after user-defines | 
| 173 | 611 |  |  |  |  | 721 | push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS; | 
|  | 611 |  |  |  |  | 1507 |  | 
| 174 |  |  |  |  |  |  |  | 
| 175 |  |  |  |  |  |  | # unary operators | 
| 176 | 611 |  | 50 |  |  | 1929 | $opt{unary_ops} ||= []; | 
| 177 | 611 |  |  |  |  | 693 | push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS; | 
|  | 611 |  |  |  |  | 1222 |  | 
| 178 |  |  |  |  |  |  |  | 
| 179 |  |  |  |  |  |  | # rudimentary sanity-check for user supplied bits treated as functions/operators | 
| 180 |  |  |  |  |  |  | # If a purported  function matches this regular expression, an exception is thrown. | 
| 181 |  |  |  |  |  |  | # Literal SQL is *NOT* subject to this check, only functions (and column names | 
| 182 |  |  |  |  |  |  | # when quoting is not in effect) | 
| 183 |  |  |  |  |  |  |  | 
| 184 |  |  |  |  |  |  | # FIXME | 
| 185 |  |  |  |  |  |  | # need to guard against ()'s in column names too, but this will break tons of | 
| 186 |  |  |  |  |  |  | # hacks... ideas anyone? | 
| 187 | 611 |  | 33 |  |  | 2364 | $opt{injection_guard} ||= qr/ | 
| 188 |  |  |  |  |  |  | \; | 
| 189 |  |  |  |  |  |  | | | 
| 190 |  |  |  |  |  |  | ^ \s* go \s | 
| 191 |  |  |  |  |  |  | /xmi; | 
| 192 |  |  |  |  |  |  |  | 
| 193 | 611 |  |  |  |  | 1611 | return bless \%opt, $class; | 
| 194 |  |  |  |  |  |  | } | 
| 195 |  |  |  |  |  |  |  | 
| 196 |  |  |  |  |  |  |  | 
| 197 |  |  |  |  |  |  | sub _assert_pass_injection_guard { | 
| 198 | 1802 | 100 |  | 1802 |  | 10043 | if ($_[1] =~ $_[0]->{injection_guard}) { | 
| 199 | 5 |  |  |  |  | 8 | my $class = ref $_[0]; | 
| 200 | 5 |  |  |  |  | 18 | puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the " | 
| 201 |  |  |  |  |  |  | . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own " | 
| 202 |  |  |  |  |  |  | . "{injection_guard} attribute to ${class}->new()" | 
| 203 |  |  |  |  |  |  | } | 
| 204 |  |  |  |  |  |  | } | 
| 205 |  |  |  |  |  |  |  | 
| 206 |  |  |  |  |  |  |  | 
| 207 |  |  |  |  |  |  | #====================================================================== | 
| 208 |  |  |  |  |  |  | # INSERT methods | 
| 209 |  |  |  |  |  |  | #====================================================================== | 
| 210 |  |  |  |  |  |  |  | 
| 211 |  |  |  |  |  |  | sub insert { | 
| 212 | 49 |  |  | 49 | 1 | 3582 | my $self    = shift; | 
| 213 | 49 |  |  |  |  | 111 | my $table   = $self->_table(shift); | 
| 214 | 49 |  | 50 |  |  | 288 | my $data    = shift || return; | 
| 215 | 49 |  |  |  |  | 64 | my $options = shift; | 
| 216 |  |  |  |  |  |  |  | 
| 217 | 49 |  |  |  |  | 106 | my $method       = $self->_METHOD_FOR_refkind("_insert", $data); | 
| 218 | 49 |  |  |  |  | 119 | my ($sql, @bind) = $self->$method($data); | 
| 219 | 47 |  |  |  |  | 88 | $sql = join " ", $self->_sqlcase('insert into'), $table, $sql; | 
| 220 |  |  |  |  |  |  |  | 
| 221 | 47 | 100 |  |  |  | 110 | if ($options->{returning}) { | 
| 222 | 10 |  |  |  |  | 20 | my ($s, @b) = $self->_insert_returning($options); | 
| 223 | 10 |  |  |  |  | 19 | $sql .= $s; | 
| 224 | 10 |  |  |  |  | 15 | push @bind, @b; | 
| 225 |  |  |  |  |  |  | } | 
| 226 |  |  |  |  |  |  |  | 
| 227 | 47 | 50 |  |  |  | 286 | return wantarray ? ($sql, @bind) : $sql; | 
| 228 |  |  |  |  |  |  | } | 
| 229 |  |  |  |  |  |  |  | 
| 230 |  |  |  |  |  |  | # So that subclasses can override INSERT ... RETURNING separately from | 
| 231 |  |  |  |  |  |  | # UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this) | 
| 232 | 10 |  |  | 10 |  | 19 | sub _insert_returning { shift->_returning(@_) } | 
| 233 |  |  |  |  |  |  |  | 
| 234 |  |  |  |  |  |  | sub _returning { | 
| 235 | 22 |  |  | 22 |  | 36 | my ($self, $options) = @_; | 
| 236 |  |  |  |  |  |  |  | 
| 237 | 22 |  |  |  |  | 30 | my $f = $options->{returning}; | 
| 238 |  |  |  |  |  |  |  | 
| 239 |  |  |  |  |  |  | my $fieldlist = $self->_SWITCH_refkind($f, { | 
| 240 | 6 |  |  | 6 |  | 9 | ARRAYREF     => sub {join ', ', map { $self->_quote($_) } @$f;}, | 
|  | 14 |  |  |  |  | 23 |  | 
| 241 | 8 |  |  | 8 |  | 16 | SCALAR       => sub {$self->_quote($f)}, | 
| 242 | 8 |  |  | 8 |  | 19 | SCALARREF    => sub {$$f}, | 
| 243 | 22 |  |  |  |  | 127 | }); | 
| 244 | 22 |  |  |  |  | 103 | return $self->_sqlcase(' returning ') . $fieldlist; | 
| 245 |  |  |  |  |  |  | } | 
| 246 |  |  |  |  |  |  |  | 
| 247 |  |  |  |  |  |  | sub _insert_HASHREF { # explicit list of fields and then values | 
| 248 | 28 |  |  | 28 |  | 60 | my ($self, $data) = @_; | 
| 249 |  |  |  |  |  |  |  | 
| 250 | 28 |  |  |  |  | 121 | my @fields = sort keys %$data; | 
| 251 |  |  |  |  |  |  |  | 
| 252 | 28 |  |  |  |  | 78 | my ($sql, @bind) = $self->_insert_values($data); | 
| 253 |  |  |  |  |  |  |  | 
| 254 |  |  |  |  |  |  | # assemble SQL | 
| 255 | 26 |  |  |  |  | 65 | $_ = $self->_quote($_) foreach @fields; | 
| 256 | 26 |  |  |  |  | 109 | $sql = "( ".join(", ", @fields).") ".$sql; | 
| 257 |  |  |  |  |  |  |  | 
| 258 | 26 |  |  |  |  | 100 | return ($sql, @bind); | 
| 259 |  |  |  |  |  |  | } | 
| 260 |  |  |  |  |  |  |  | 
| 261 |  |  |  |  |  |  | sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields) | 
| 262 | 21 |  |  | 21 |  | 35 | my ($self, $data) = @_; | 
| 263 |  |  |  |  |  |  |  | 
| 264 |  |  |  |  |  |  | # no names (arrayref) so can't generate bindtype | 
| 265 | 21 | 50 |  |  |  | 50 | $self->{bindtype} ne 'columns' | 
| 266 |  |  |  |  |  |  | or belch "can't do 'columns' bindtype when called with arrayref"; | 
| 267 |  |  |  |  |  |  |  | 
| 268 | 21 |  |  |  |  | 35 | my (@values, @all_bind); | 
| 269 | 21 |  |  |  |  | 36 | foreach my $value (@$data) { | 
| 270 | 156 |  |  |  |  | 249 | my ($values, @bind) = $self->_insert_value(undef, $value); | 
| 271 | 156 |  |  |  |  | 223 | push @values, $values; | 
| 272 | 156 |  |  |  |  | 233 | push @all_bind, @bind; | 
| 273 |  |  |  |  |  |  | } | 
| 274 | 21 |  |  |  |  | 37 | my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )"; | 
| 275 | 21 |  |  |  |  | 82 | return ($sql, @all_bind); | 
| 276 |  |  |  |  |  |  | } | 
| 277 |  |  |  |  |  |  |  | 
| 278 |  |  |  |  |  |  | sub _insert_ARRAYREFREF { # literal SQL with bind | 
| 279 | 0 |  |  | 0 |  | 0 | my ($self, $data) = @_; | 
| 280 |  |  |  |  |  |  |  | 
| 281 | 0 |  |  |  |  | 0 | my ($sql, @bind) = @${$data}; | 
|  | 0 |  |  |  |  | 0 |  | 
| 282 | 0 |  |  |  |  | 0 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 283 |  |  |  |  |  |  |  | 
| 284 | 0 |  |  |  |  | 0 | return ($sql, @bind); | 
| 285 |  |  |  |  |  |  | } | 
| 286 |  |  |  |  |  |  |  | 
| 287 |  |  |  |  |  |  |  | 
| 288 |  |  |  |  |  |  | sub _insert_SCALARREF { # literal SQL without bind | 
| 289 | 0 |  |  | 0 |  | 0 | my ($self, $data) = @_; | 
| 290 |  |  |  |  |  |  |  | 
| 291 | 0 |  |  |  |  | 0 | return ($$data); | 
| 292 |  |  |  |  |  |  | } | 
| 293 |  |  |  |  |  |  |  | 
| 294 |  |  |  |  |  |  | sub _insert_values { | 
| 295 | 28 |  |  | 28 |  | 46 | my ($self, $data) = @_; | 
| 296 |  |  |  |  |  |  |  | 
| 297 | 28 |  |  |  |  | 35 | my (@values, @all_bind); | 
| 298 | 28 |  |  |  |  | 71 | foreach my $column (sort keys %$data) { | 
| 299 | 95 |  |  |  |  | 177 | my ($values, @bind) = $self->_insert_value($column, $data->{$column}); | 
| 300 | 93 |  |  |  |  | 140 | push @values, $values; | 
| 301 | 93 |  |  |  |  | 137 | push @all_bind, @bind; | 
| 302 |  |  |  |  |  |  | } | 
| 303 | 26 |  |  |  |  | 73 | my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )"; | 
| 304 | 26 |  |  |  |  | 77 | return ($sql, @all_bind); | 
| 305 |  |  |  |  |  |  | } | 
| 306 |  |  |  |  |  |  |  | 
| 307 |  |  |  |  |  |  | sub _insert_value { | 
| 308 | 251 |  |  | 251 |  | 349 | my ($self, $column, $v) = @_; | 
| 309 |  |  |  |  |  |  |  | 
| 310 | 251 |  |  |  |  | 272 | my (@values, @all_bind); | 
| 311 |  |  |  |  |  |  | $self->_SWITCH_refkind($v, { | 
| 312 |  |  |  |  |  |  |  | 
| 313 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 314 | 5 | 100 |  | 5 |  | 9 | if ($self->{array_datatypes}) { # if array datatype are activated | 
| 315 | 4 |  |  |  |  | 7 | push @values, '?'; | 
| 316 | 4 |  |  |  |  | 7 | push @all_bind, $self->_bindtype($column, $v); | 
| 317 |  |  |  |  |  |  | } | 
| 318 |  |  |  |  |  |  | else {                  # else literal SQL with bind | 
| 319 | 1 |  |  |  |  | 3 | my ($sql, @bind) = @$v; | 
| 320 | 1 |  |  |  |  | 3 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 321 | 1 |  |  |  |  | 2 | push @values, $sql; | 
| 322 | 1 |  |  |  |  | 2 | push @all_bind, @bind; | 
| 323 |  |  |  |  |  |  | } | 
| 324 |  |  |  |  |  |  | }, | 
| 325 |  |  |  |  |  |  |  | 
| 326 |  |  |  |  |  |  | ARRAYREFREF => sub {        # literal SQL with bind | 
| 327 | 11 |  |  | 11 |  | 17 | my ($sql, @bind) = @${$v}; | 
|  | 11 |  |  |  |  | 27 |  | 
| 328 | 11 |  |  |  |  | 29 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 329 | 9 |  |  |  |  | 13 | push @values, $sql; | 
| 330 | 9 |  |  |  |  | 17 | push @all_bind, @bind; | 
| 331 |  |  |  |  |  |  | }, | 
| 332 |  |  |  |  |  |  |  | 
| 333 |  |  |  |  |  |  | # THINK: anything useful to do with a HASHREF ? | 
| 334 |  |  |  |  |  |  | HASHREF => sub {       # (nothing, but old SQLA passed it through) | 
| 335 |  |  |  |  |  |  | #TODO in SQLA >= 2.0 it will die instead | 
| 336 | 2 |  |  | 2 |  | 6 | belch "HASH ref as bind value in insert is not supported"; | 
| 337 | 2 |  |  |  |  | 1808 | push @values, '?'; | 
| 338 | 2 |  |  |  |  | 7 | push @all_bind, $self->_bindtype($column, $v); | 
| 339 |  |  |  |  |  |  | }, | 
| 340 |  |  |  |  |  |  |  | 
| 341 |  |  |  |  |  |  | SCALARREF => sub {          # literal SQL without bind | 
| 342 | 6 |  |  | 6 |  | 14 | push @values, $$v; | 
| 343 |  |  |  |  |  |  | }, | 
| 344 |  |  |  |  |  |  |  | 
| 345 |  |  |  |  |  |  | SCALAR_or_UNDEF => sub { | 
| 346 | 227 |  |  | 227 |  | 293 | push @values, '?'; | 
| 347 | 227 |  |  |  |  | 345 | push @all_bind, $self->_bindtype($column, $v); | 
| 348 |  |  |  |  |  |  | }, | 
| 349 |  |  |  |  |  |  |  | 
| 350 | 251 |  |  |  |  | 1752 | }); | 
| 351 |  |  |  |  |  |  |  | 
| 352 | 249 |  |  |  |  | 1387 | my $sql = join(", ", @values); | 
| 353 | 249 |  |  |  |  | 608 | return ($sql, @all_bind); | 
| 354 |  |  |  |  |  |  | } | 
| 355 |  |  |  |  |  |  |  | 
| 356 |  |  |  |  |  |  |  | 
| 357 |  |  |  |  |  |  |  | 
| 358 |  |  |  |  |  |  | #====================================================================== | 
| 359 |  |  |  |  |  |  | # UPDATE methods | 
| 360 |  |  |  |  |  |  | #====================================================================== | 
| 361 |  |  |  |  |  |  |  | 
| 362 |  |  |  |  |  |  |  | 
| 363 |  |  |  |  |  |  | sub update { | 
| 364 | 38 |  |  | 38 | 1 | 1662 | my $self    = shift; | 
| 365 | 38 |  |  |  |  | 100 | my $table   = $self->_table(shift); | 
| 366 | 38 |  | 50 |  |  | 251 | my $data    = shift || return; | 
| 367 | 38 |  |  |  |  | 49 | my $where   = shift; | 
| 368 | 38 |  |  |  |  | 53 | my $options = shift; | 
| 369 |  |  |  |  |  |  |  | 
| 370 |  |  |  |  |  |  | # first build the 'SET' part of the sql statement | 
| 371 | 38 | 50 |  |  |  | 91 | puke "Unsupported data type specified to \$sql->update" | 
| 372 |  |  |  |  |  |  | unless ref $data eq 'HASH'; | 
| 373 |  |  |  |  |  |  |  | 
| 374 | 38 |  |  |  |  | 101 | my ($sql, @all_bind) = $self->_update_set_values($data); | 
| 375 | 36 |  |  |  |  | 85 | $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ') | 
| 376 |  |  |  |  |  |  | . $sql; | 
| 377 |  |  |  |  |  |  |  | 
| 378 | 36 | 100 |  |  |  | 90 | if ($where) { | 
| 379 | 30 |  |  |  |  | 69 | my($where_sql, @where_bind) = $self->where($where); | 
| 380 | 30 |  |  |  |  | 73 | $sql .= $where_sql; | 
| 381 | 30 |  |  |  |  | 58 | push @all_bind, @where_bind; | 
| 382 |  |  |  |  |  |  | } | 
| 383 |  |  |  |  |  |  |  | 
| 384 | 36 | 100 |  |  |  | 101 | if ($options->{returning}) { | 
| 385 | 6 |  |  |  |  | 12 | my ($returning_sql, @returning_bind) = $self->_update_returning($options); | 
| 386 | 6 |  |  |  |  | 11 | $sql .= $returning_sql; | 
| 387 | 6 |  |  |  |  | 11 | push @all_bind, @returning_bind; | 
| 388 |  |  |  |  |  |  | } | 
| 389 |  |  |  |  |  |  |  | 
| 390 | 36 | 50 |  |  |  | 228 | return wantarray ? ($sql, @all_bind) : $sql; | 
| 391 |  |  |  |  |  |  | } | 
| 392 |  |  |  |  |  |  |  | 
| 393 |  |  |  |  |  |  | sub _update_set_values { | 
| 394 | 38 |  |  | 38 |  | 59 | my ($self, $data) = @_; | 
| 395 |  |  |  |  |  |  |  | 
| 396 | 38 |  |  |  |  | 59 | my (@set, @all_bind); | 
| 397 | 38 |  |  |  |  | 158 | for my $k (sort keys %$data) { | 
| 398 | 78 |  |  |  |  | 130 | my $v = $data->{$k}; | 
| 399 | 78 |  |  |  |  | 147 | my $r = ref $v; | 
| 400 | 78 |  |  |  |  | 123 | my $label = $self->_quote($k); | 
| 401 |  |  |  |  |  |  |  | 
| 402 |  |  |  |  |  |  | $self->_SWITCH_refkind($v, { | 
| 403 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 404 | 4 | 50 |  | 4 |  | 12 | if ($self->{array_datatypes}) { # array datatype | 
| 405 | 4 |  |  |  |  | 11 | push @set, "$label = ?"; | 
| 406 | 4 |  |  |  |  | 8 | push @all_bind, $self->_bindtype($k, $v); | 
| 407 |  |  |  |  |  |  | } | 
| 408 |  |  |  |  |  |  | else {                          # literal SQL with bind | 
| 409 | 0 |  |  |  |  | 0 | my ($sql, @bind) = @$v; | 
| 410 | 0 |  |  |  |  | 0 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 411 | 0 |  |  |  |  | 0 | push @set, "$label = $sql"; | 
| 412 | 0 |  |  |  |  | 0 | push @all_bind, @bind; | 
| 413 |  |  |  |  |  |  | } | 
| 414 |  |  |  |  |  |  | }, | 
| 415 |  |  |  |  |  |  | ARRAYREFREF => sub { # literal SQL with bind | 
| 416 | 10 |  |  | 10 |  | 15 | my ($sql, @bind) = @${$v}; | 
|  | 10 |  |  |  |  | 26 |  | 
| 417 | 10 |  |  |  |  | 26 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 418 | 8 |  |  |  |  | 17 | push @set, "$label = $sql"; | 
| 419 | 8 |  |  |  |  | 70 | push @all_bind, @bind; | 
| 420 |  |  |  |  |  |  | }, | 
| 421 |  |  |  |  |  |  | SCALARREF => sub {  # literal SQL without bind | 
| 422 | 0 |  |  | 0 |  | 0 | push @set, "$label = $$v"; | 
| 423 |  |  |  |  |  |  | }, | 
| 424 |  |  |  |  |  |  | HASHREF => sub { | 
| 425 | 4 |  |  | 4 |  | 21 | my ($op, $arg, @rest) = %$v; | 
| 426 |  |  |  |  |  |  |  | 
| 427 | 4 | 50 | 33 |  |  | 28 | puke 'Operator calls in update must be in the form { -op => $arg }' | 
| 428 |  |  |  |  |  |  | if (@rest or not $op =~ /^\-(.+)/); | 
| 429 |  |  |  |  |  |  |  | 
| 430 | 4 |  |  |  |  | 11 | local $self->{_nested_func_lhs} = $k; | 
| 431 | 4 |  |  |  |  | 14 | my ($sql, @bind) = $self->_where_unary_op($1, $arg); | 
| 432 |  |  |  |  |  |  |  | 
| 433 | 4 |  |  |  |  | 18 | push @set, "$label = $sql"; | 
| 434 | 4 |  |  |  |  | 62 | push @all_bind, @bind; | 
| 435 |  |  |  |  |  |  | }, | 
| 436 |  |  |  |  |  |  | SCALAR_or_UNDEF => sub { | 
| 437 | 60 |  |  | 60 |  | 113 | push @set, "$label = ?"; | 
| 438 | 60 |  |  |  |  | 126 | push @all_bind, $self->_bindtype($k, $v); | 
| 439 |  |  |  |  |  |  | }, | 
| 440 | 78 |  |  |  |  | 819 | }); | 
| 441 |  |  |  |  |  |  | } | 
| 442 |  |  |  |  |  |  |  | 
| 443 |  |  |  |  |  |  | # generate sql | 
| 444 | 36 |  |  |  |  | 90 | my $sql = join ', ', @set; | 
| 445 |  |  |  |  |  |  |  | 
| 446 | 36 |  |  |  |  | 105 | return ($sql, @all_bind); | 
| 447 |  |  |  |  |  |  | } | 
| 448 |  |  |  |  |  |  |  | 
| 449 |  |  |  |  |  |  | # So that subclasses can override UPDATE ... RETURNING separately from | 
| 450 |  |  |  |  |  |  | # INSERT and DELETE | 
| 451 | 6 |  |  | 6 |  | 15 | sub _update_returning { shift->_returning(@_) } | 
| 452 |  |  |  |  |  |  |  | 
| 453 |  |  |  |  |  |  |  | 
| 454 |  |  |  |  |  |  |  | 
| 455 |  |  |  |  |  |  | #====================================================================== | 
| 456 |  |  |  |  |  |  | # SELECT | 
| 457 |  |  |  |  |  |  | #====================================================================== | 
| 458 |  |  |  |  |  |  |  | 
| 459 |  |  |  |  |  |  |  | 
| 460 |  |  |  |  |  |  | sub select { | 
| 461 | 102 |  |  | 102 | 1 | 12428 | my $self   = shift; | 
| 462 | 102 |  |  |  |  | 225 | my $table  = $self->_table(shift); | 
| 463 | 102 |  | 50 |  |  | 638 | my $fields = shift || '*'; | 
| 464 | 102 |  |  |  |  | 157 | my $where  = shift; | 
| 465 | 102 |  |  |  |  | 121 | my $order  = shift; | 
| 466 |  |  |  |  |  |  |  | 
| 467 | 102 |  |  |  |  | 213 | my ($fields_sql, @bind) = $self->_select_fields($fields); | 
| 468 |  |  |  |  |  |  |  | 
| 469 | 102 |  |  |  |  | 218 | my ($where_sql, @where_bind) = $self->where($where, $order); | 
| 470 | 89 |  |  |  |  | 148 | push @bind, @where_bind; | 
| 471 |  |  |  |  |  |  |  | 
| 472 | 89 |  |  |  |  | 155 | my $sql = join(' ', $self->_sqlcase('select'), $fields_sql, | 
| 473 |  |  |  |  |  |  | $self->_sqlcase('from'),   $table) | 
| 474 |  |  |  |  |  |  | . $where_sql; | 
| 475 |  |  |  |  |  |  |  | 
| 476 | 89 | 100 |  |  |  | 527 | return wantarray ? ($sql, @bind) : $sql; | 
| 477 |  |  |  |  |  |  | } | 
| 478 |  |  |  |  |  |  |  | 
| 479 |  |  |  |  |  |  | sub _select_fields { | 
| 480 | 102 |  |  | 102 |  | 188 | my ($self, $fields) = @_; | 
| 481 | 102 | 100 |  |  |  | 258 | return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields | 
|  | 22 |  |  |  |  | 39 |  | 
| 482 |  |  |  |  |  |  | : $fields; | 
| 483 |  |  |  |  |  |  | } | 
| 484 |  |  |  |  |  |  |  | 
| 485 |  |  |  |  |  |  | #====================================================================== | 
| 486 |  |  |  |  |  |  | # DELETE | 
| 487 |  |  |  |  |  |  | #====================================================================== | 
| 488 |  |  |  |  |  |  |  | 
| 489 |  |  |  |  |  |  |  | 
| 490 |  |  |  |  |  |  | sub delete { | 
| 491 | 10 |  |  | 10 | 1 | 431 | my $self    = shift; | 
| 492 | 10 |  |  |  |  | 25 | my $table   = $self->_table(shift); | 
| 493 | 10 |  |  |  |  | 52 | my $where   = shift; | 
| 494 | 10 |  |  |  |  | 15 | my $options = shift; | 
| 495 |  |  |  |  |  |  |  | 
| 496 | 10 |  |  |  |  | 22 | my($where_sql, @bind) = $self->where($where); | 
| 497 | 10 |  |  |  |  | 21 | my $sql = $self->_sqlcase('delete from ') . $table . $where_sql; | 
| 498 |  |  |  |  |  |  |  | 
| 499 | 10 | 100 |  |  |  | 24 | if ($options->{returning}) { | 
| 500 | 6 |  |  |  |  | 13 | my ($returning_sql, @returning_bind) = $self->_delete_returning($options); | 
| 501 | 6 |  |  |  |  | 11 | $sql .= $returning_sql; | 
| 502 | 6 |  |  |  |  | 11 | push @bind, @returning_bind; | 
| 503 |  |  |  |  |  |  | } | 
| 504 |  |  |  |  |  |  |  | 
| 505 | 10 | 50 |  |  |  | 55 | return wantarray ? ($sql, @bind) : $sql; | 
| 506 |  |  |  |  |  |  | } | 
| 507 |  |  |  |  |  |  |  | 
| 508 |  |  |  |  |  |  | # So that subclasses can override DELETE ... RETURNING separately from | 
| 509 |  |  |  |  |  |  | # INSERT and UPDATE | 
| 510 | 6 |  |  | 6 |  | 12 | sub _delete_returning { shift->_returning(@_) } | 
| 511 |  |  |  |  |  |  |  | 
| 512 |  |  |  |  |  |  |  | 
| 513 |  |  |  |  |  |  |  | 
| 514 |  |  |  |  |  |  | #====================================================================== | 
| 515 |  |  |  |  |  |  | # WHERE: entry point | 
| 516 |  |  |  |  |  |  | #====================================================================== | 
| 517 |  |  |  |  |  |  |  | 
| 518 |  |  |  |  |  |  |  | 
| 519 |  |  |  |  |  |  |  | 
| 520 |  |  |  |  |  |  | # Finally, a separate routine just to handle WHERE clauses | 
| 521 |  |  |  |  |  |  | sub where { | 
| 522 | 619 |  |  | 619 | 1 | 21920 | my ($self, $where, $order) = @_; | 
| 523 |  |  |  |  |  |  |  | 
| 524 |  |  |  |  |  |  | # where ? | 
| 525 | 619 |  |  |  |  | 1165 | my ($sql, @bind) = $self->_recurse_where($where); | 
| 526 | 509 | 100 | 66 |  |  | 1894 | $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : ''; | 
| 527 |  |  |  |  |  |  |  | 
| 528 |  |  |  |  |  |  | # order by? | 
| 529 | 509 | 100 |  |  |  | 968 | if ($order) { | 
| 530 | 50 |  |  |  |  | 105 | my ($order_sql, @order_bind) = $self->_order_by($order); | 
| 531 | 50 |  |  |  |  | 95 | $sql .= $order_sql; | 
| 532 | 50 |  |  |  |  | 79 | push @bind, @order_bind; | 
| 533 |  |  |  |  |  |  | } | 
| 534 |  |  |  |  |  |  |  | 
| 535 | 509 | 50 |  |  |  | 2300 | return wantarray ? ($sql, @bind) : $sql; | 
| 536 |  |  |  |  |  |  | } | 
| 537 |  |  |  |  |  |  |  | 
| 538 |  |  |  |  |  |  |  | 
| 539 |  |  |  |  |  |  | sub _recurse_where { | 
| 540 | 1471 |  |  | 1471 |  | 2201 | my ($self, $where, $logic) = @_; | 
| 541 |  |  |  |  |  |  |  | 
| 542 |  |  |  |  |  |  | # dispatch on appropriate method according to refkind of $where | 
| 543 | 1471 |  |  |  |  | 2445 | my $method = $self->_METHOD_FOR_refkind("_where", $where); | 
| 544 |  |  |  |  |  |  |  | 
| 545 | 1471 |  |  |  |  | 2792 | my ($sql, @bind) =  $self->$method($where, $logic); | 
| 546 |  |  |  |  |  |  |  | 
| 547 |  |  |  |  |  |  | # DBIx::Class used to call _recurse_where in scalar context | 
| 548 |  |  |  |  |  |  | # something else might too... | 
| 549 | 1347 | 50 |  |  |  | 2755 | if (wantarray) { | 
| 550 | 1347 |  |  |  |  | 4106 | return ($sql, @bind); | 
| 551 |  |  |  |  |  |  | } | 
| 552 |  |  |  |  |  |  | else { | 
| 553 | 0 |  |  |  |  | 0 | belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0"; | 
| 554 | 0 |  |  |  |  | 0 | return $sql; | 
| 555 |  |  |  |  |  |  | } | 
| 556 |  |  |  |  |  |  | } | 
| 557 |  |  |  |  |  |  |  | 
| 558 |  |  |  |  |  |  |  | 
| 559 |  |  |  |  |  |  |  | 
| 560 |  |  |  |  |  |  | #====================================================================== | 
| 561 |  |  |  |  |  |  | # WHERE: top-level ARRAYREF | 
| 562 |  |  |  |  |  |  | #====================================================================== | 
| 563 |  |  |  |  |  |  |  | 
| 564 |  |  |  |  |  |  |  | 
| 565 |  |  |  |  |  |  | sub _where_ARRAYREF { | 
| 566 | 395 |  |  | 395 |  | 703 | my ($self, $where, $logic) = @_; | 
| 567 |  |  |  |  |  |  |  | 
| 568 | 395 |  | 66 |  |  | 1137 | $logic = uc($logic || $self->{logic}); | 
| 569 | 395 | 50 | 66 |  |  | 1189 | $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic"; | 
| 570 |  |  |  |  |  |  |  | 
| 571 | 395 |  |  |  |  | 728 | my @clauses = @$where; | 
| 572 |  |  |  |  |  |  |  | 
| 573 | 395 |  |  |  |  | 547 | my (@sql_clauses, @all_bind); | 
| 574 |  |  |  |  |  |  | # need to use while() so can shift() for pairs | 
| 575 | 395 |  |  |  |  | 701 | while (@clauses) { | 
| 576 | 688 |  |  |  |  | 965 | my $el = shift @clauses; | 
| 577 |  |  |  |  |  |  |  | 
| 578 | 688 | 100 | 100 |  |  | 2065 | $el = undef if (defined $el and ! length $el); | 
| 579 |  |  |  |  |  |  |  | 
| 580 |  |  |  |  |  |  | # switch according to kind of $el and get corresponding ($sql, @bind) | 
| 581 |  |  |  |  |  |  | my ($sql, @bind) = $self->_SWITCH_refkind($el, { | 
| 582 |  |  |  |  |  |  |  | 
| 583 |  |  |  |  |  |  | # skip empty elements, otherwise get invalid trailing AND stuff | 
| 584 | 15 | 50 |  | 15 |  | 56 | ARRAYREF  => sub {$self->_recurse_where($el)        if @$el}, | 
| 585 |  |  |  |  |  |  |  | 
| 586 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 587 | 1 |  |  | 1 |  | 2 | my ($s, @b) = @$$el; | 
| 588 | 1 |  |  |  |  | 4 | $self->_assert_bindval_matches_bindtype(@b); | 
| 589 | 1 |  |  |  |  | 3 | ($s, @b); | 
| 590 |  |  |  |  |  |  | }, | 
| 591 |  |  |  |  |  |  |  | 
| 592 | 273 | 100 |  | 273 |  | 788 | HASHREF   => sub {$self->_recurse_where($el, 'and') if %$el}, | 
| 593 |  |  |  |  |  |  |  | 
| 594 | 0 |  |  | 0 |  | 0 | SCALARREF => sub { ($$el);                                 }, | 
| 595 |  |  |  |  |  |  |  | 
| 596 |  |  |  |  |  |  | SCALAR    => sub { | 
| 597 |  |  |  |  |  |  | # top-level arrayref with scalars, recurse in pairs | 
| 598 | 347 |  |  | 347 |  | 829 | $self->_recurse_where({$el => shift(@clauses)}) | 
| 599 |  |  |  |  |  |  | }, | 
| 600 |  |  |  |  |  |  |  | 
| 601 | 52 |  |  | 52 |  | 99 | UNDEF     => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" }, | 
| 602 | 688 |  |  |  |  | 5948 | }); | 
| 603 |  |  |  |  |  |  |  | 
| 604 | 624 | 100 |  |  |  | 3956 | if ($sql) { | 
| 605 | 623 |  |  |  |  | 923 | push @sql_clauses, $sql; | 
| 606 | 623 |  |  |  |  | 1420 | push @all_bind, @bind; | 
| 607 |  |  |  |  |  |  | } | 
| 608 |  |  |  |  |  |  | } | 
| 609 |  |  |  |  |  |  |  | 
| 610 | 331 |  |  |  |  | 704 | return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind); | 
| 611 |  |  |  |  |  |  | } | 
| 612 |  |  |  |  |  |  |  | 
| 613 |  |  |  |  |  |  | #====================================================================== | 
| 614 |  |  |  |  |  |  | # WHERE: top-level ARRAYREFREF | 
| 615 |  |  |  |  |  |  | #====================================================================== | 
| 616 |  |  |  |  |  |  |  | 
| 617 |  |  |  |  |  |  | sub _where_ARRAYREFREF { | 
| 618 | 6 |  |  | 6 |  | 13 | my ($self, $where) = @_; | 
| 619 | 6 |  |  |  |  | 14 | my ($sql, @bind) = @$$where; | 
| 620 | 6 |  |  |  |  | 17 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 621 | 6 |  |  |  |  | 14 | return ($sql, @bind); | 
| 622 |  |  |  |  |  |  | } | 
| 623 |  |  |  |  |  |  |  | 
| 624 |  |  |  |  |  |  | #====================================================================== | 
| 625 |  |  |  |  |  |  | # WHERE: top-level HASHREF | 
| 626 |  |  |  |  |  |  | #====================================================================== | 
| 627 |  |  |  |  |  |  |  | 
| 628 |  |  |  |  |  |  | sub _where_HASHREF { | 
| 629 | 1164 |  |  | 1164 |  | 1736 | my ($self, $where) = @_; | 
| 630 | 1164 |  |  |  |  | 1384 | my (@sql_clauses, @all_bind); | 
| 631 |  |  |  |  |  |  |  | 
| 632 | 1164 |  |  |  |  | 3416 | for my $k (sort keys %$where) { | 
| 633 | 1392 |  |  |  |  | 2073 | my $v = $where->{$k}; | 
| 634 |  |  |  |  |  |  |  | 
| 635 |  |  |  |  |  |  | # ($k => $v) is either a special unary op or a regular hashpair | 
| 636 | 1392 |  |  |  |  | 1492 | my ($sql, @bind) = do { | 
| 637 | 1392 | 100 |  |  |  | 2756 | if ($k =~ /^-./) { | 
| 638 |  |  |  |  |  |  | # put the operator in canonical form | 
| 639 | 225 |  |  |  |  | 325 | my $op = $k; | 
| 640 | 225 |  |  |  |  | 429 | $op = substr $op, 1;  # remove initial dash | 
| 641 | 225 |  |  |  |  | 639 | $op =~ s/^\s+|\s+$//g;# remove leading/trailing space | 
| 642 | 225 |  |  |  |  | 359 | $op =~ s/\s+/ /g;     # compress whitespace | 
| 643 |  |  |  |  |  |  |  | 
| 644 |  |  |  |  |  |  | # so that -not_foo works correctly | 
| 645 | 225 |  |  |  |  | 297 | $op =~ s/^not_/NOT /i; | 
| 646 |  |  |  |  |  |  |  | 
| 647 | 225 |  |  |  |  | 675 | $self->_debug("Unary OP(-$op) within hashref, recursing..."); | 
| 648 | 225 |  |  |  |  | 496 | my ($s, @b) = $self->_where_unary_op($op, $v); | 
| 649 |  |  |  |  |  |  |  | 
| 650 |  |  |  |  |  |  | # top level vs nested | 
| 651 |  |  |  |  |  |  | # we assume that handled unary ops will take care of their ()s | 
| 652 |  |  |  |  |  |  | $s = "($s)" unless ( | 
| 653 | 505 |  |  | 505 |  | 1902 | List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}} | 
|  | 201 |  |  |  |  | 528 |  | 
| 654 |  |  |  |  |  |  | or | 
| 655 | 201 | 50 | 66 |  |  | 678 | ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k ) | 
|  |  |  | 66 |  |  |  |  | 
| 656 |  |  |  |  |  |  | ); | 
| 657 | 201 |  |  |  |  | 727 | ($s, @b); | 
| 658 |  |  |  |  |  |  | } | 
| 659 |  |  |  |  |  |  | else { | 
| 660 | 1167 | 100 |  |  |  | 1882 | if (! length $k) { | 
| 661 | 44 | 100 |  |  |  | 83 | if (is_literal_value ($v) ) { | 
| 662 | 20 |  |  |  |  | 39 | belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; | 
| 663 |  |  |  |  |  |  | } | 
| 664 |  |  |  |  |  |  | else { | 
| 665 | 24 |  |  |  |  | 37 | puke "Supplying an empty left hand side argument is not supported in hash-pairs"; | 
| 666 |  |  |  |  |  |  | } | 
| 667 |  |  |  |  |  |  | } | 
| 668 |  |  |  |  |  |  |  | 
| 669 | 1143 |  |  |  |  | 15624 | my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v); | 
| 670 | 1143 |  |  |  |  | 2105 | $self->$method($k, $v); | 
| 671 |  |  |  |  |  |  | } | 
| 672 |  |  |  |  |  |  | }; | 
| 673 |  |  |  |  |  |  |  | 
| 674 | 1312 |  |  |  |  | 2209 | push @sql_clauses, $sql; | 
| 675 | 1312 |  |  |  |  | 2419 | push @all_bind, @bind; | 
| 676 |  |  |  |  |  |  | } | 
| 677 |  |  |  |  |  |  |  | 
| 678 | 1084 |  |  |  |  | 2464 | return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind); | 
| 679 |  |  |  |  |  |  | } | 
| 680 |  |  |  |  |  |  |  | 
| 681 |  |  |  |  |  |  | sub _where_unary_op { | 
| 682 | 446 |  |  | 446 |  | 827 | my ($self, $op, $rhs) = @_; | 
| 683 |  |  |  |  |  |  |  | 
| 684 |  |  |  |  |  |  | # top level special ops are illegal in general | 
| 685 |  |  |  |  |  |  | # this includes the -ident/-value ops (dual purpose unary and special) | 
| 686 |  |  |  |  |  |  | puke "Illegal use of top-level '-$op'" | 
| 687 | 446 | 100 | 100 | 1028 |  | 1366 | if ! defined $self->{_nested_func_lhs} and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}; | 
|  | 1028 |  |  |  |  | 2865 |  | 
|  | 207 |  |  |  |  | 583 |  | 
| 688 |  |  |  |  |  |  |  | 
| 689 | 444 | 100 |  | 1873 |  | 1325 | if (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { | 
|  | 1873 |  |  |  |  | 4925 |  | 
|  | 444 |  |  |  |  | 1089 |  | 
| 690 | 204 |  |  |  |  | 358 | my $handler = $op_entry->{handler}; | 
| 691 |  |  |  |  |  |  |  | 
| 692 | 204 | 50 |  |  |  | 359 | if (not ref $handler) { | 
|  |  | 0 |  |  |  |  |  | 
| 693 | 204 | 100 |  |  |  | 700 | if ($op =~ s/ [_\s]? \d+ $//x ) { | 
| 694 | 9 |  |  |  |  | 30 | belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. ' | 
| 695 |  |  |  |  |  |  | . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]"; | 
| 696 |  |  |  |  |  |  | } | 
| 697 | 204 |  |  |  |  | 2775 | return $self->$handler($op, $rhs); | 
| 698 |  |  |  |  |  |  | } | 
| 699 |  |  |  |  |  |  | elsif (ref $handler eq 'CODE') { | 
| 700 | 0 |  |  |  |  | 0 | return $handler->($self, $op, $rhs); | 
| 701 |  |  |  |  |  |  | } | 
| 702 |  |  |  |  |  |  | else { | 
| 703 | 0 |  |  |  |  | 0 | puke "Illegal handler for operator $op - expecting a method name or a coderef"; | 
| 704 |  |  |  |  |  |  | } | 
| 705 |  |  |  |  |  |  | } | 
| 706 |  |  |  |  |  |  |  | 
| 707 | 240 |  |  |  |  | 1067 | $self->_debug("Generic unary OP: $op - recursing as function"); | 
| 708 |  |  |  |  |  |  |  | 
| 709 | 240 |  |  |  |  | 550 | $self->_assert_pass_injection_guard($op); | 
| 710 |  |  |  |  |  |  |  | 
| 711 |  |  |  |  |  |  | my ($sql, @bind) = $self->_SWITCH_refkind($rhs, { | 
| 712 |  |  |  |  |  |  | SCALAR =>   sub { | 
| 713 |  |  |  |  |  |  | puke "Illegal use of top-level '-$op'" | 
| 714 | 207 | 50 |  | 207 |  | 382 | unless defined $self->{_nested_func_lhs}; | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | return ( | 
| 717 |  |  |  |  |  |  | $self->_convert('?'), | 
| 718 | 207 |  |  |  |  | 395 | $self->_bindtype($self->{_nested_func_lhs}, $rhs) | 
| 719 |  |  |  |  |  |  | ); | 
| 720 |  |  |  |  |  |  | }, | 
| 721 |  |  |  |  |  |  | FALLBACK => sub { | 
| 722 | 31 |  |  | 31 |  | 75 | $self->_recurse_where($rhs) | 
| 723 |  |  |  |  |  |  | }, | 
| 724 | 238 |  |  |  |  | 1357 | }); | 
| 725 |  |  |  |  |  |  |  | 
| 726 | 236 |  |  |  |  | 1462 | $sql = sprintf('%s %s', | 
| 727 |  |  |  |  |  |  | $self->_sqlcase($op), | 
| 728 |  |  |  |  |  |  | $sql, | 
| 729 |  |  |  |  |  |  | ); | 
| 730 |  |  |  |  |  |  |  | 
| 731 | 236 |  |  |  |  | 667 | return ($sql, @bind); | 
| 732 |  |  |  |  |  |  | } | 
| 733 |  |  |  |  |  |  |  | 
| 734 |  |  |  |  |  |  | sub _where_op_ANDOR { | 
| 735 | 146 |  |  | 146 |  | 271 | my ($self, $op, $v) = @_; | 
| 736 |  |  |  |  |  |  |  | 
| 737 |  |  |  |  |  |  | $self->_SWITCH_refkind($v, { | 
| 738 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 739 | 76 |  |  | 76 |  | 142 | return $self->_where_ARRAYREF($v, $op); | 
| 740 |  |  |  |  |  |  | }, | 
| 741 |  |  |  |  |  |  |  | 
| 742 |  |  |  |  |  |  | HASHREF => sub { | 
| 743 |  |  |  |  |  |  | return ($op =~ /^or/i) | 
| 744 | 70 | 100 |  | 70 |  | 331 | ? $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], $op) | 
|  | 67 |  |  |  |  | 205 |  | 
| 745 |  |  |  |  |  |  | : $self->_where_HASHREF($v); | 
| 746 |  |  |  |  |  |  | }, | 
| 747 |  |  |  |  |  |  |  | 
| 748 |  |  |  |  |  |  | SCALARREF  => sub { | 
| 749 | 0 | 0 |  | 0 |  | 0 | puke "-$op => \\\$scalar makes little sense, use " . | 
| 750 |  |  |  |  |  |  | ($op =~ /^or/i | 
| 751 |  |  |  |  |  |  | ? '[ \$scalar, \%rest_of_conditions ] instead' | 
| 752 |  |  |  |  |  |  | : '-and => [ \$scalar, \%rest_of_conditions ] instead' | 
| 753 |  |  |  |  |  |  | ); | 
| 754 |  |  |  |  |  |  | }, | 
| 755 |  |  |  |  |  |  |  | 
| 756 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 757 | 0 | 0 |  | 0 |  | 0 | puke "-$op => \\[...] makes little sense, use " . | 
| 758 |  |  |  |  |  |  | ($op =~ /^or/i | 
| 759 |  |  |  |  |  |  | ? '[ \[...], \%rest_of_conditions ] instead' | 
| 760 |  |  |  |  |  |  | : '-and => [ \[...], \%rest_of_conditions ] instead' | 
| 761 |  |  |  |  |  |  | ); | 
| 762 |  |  |  |  |  |  | }, | 
| 763 |  |  |  |  |  |  |  | 
| 764 |  |  |  |  |  |  | SCALAR => sub { # permissively interpreted as SQL | 
| 765 | 0 |  |  | 0 |  | 0 | puke "-$op => \$value makes little sense, use -bool => \$value instead"; | 
| 766 |  |  |  |  |  |  | }, | 
| 767 |  |  |  |  |  |  |  | 
| 768 |  |  |  |  |  |  | UNDEF => sub { | 
| 769 | 0 |  |  | 0 |  | 0 | puke "-$op => undef not supported"; | 
| 770 |  |  |  |  |  |  | }, | 
| 771 | 146 |  |  |  |  | 1442 | }); | 
| 772 |  |  |  |  |  |  | } | 
| 773 |  |  |  |  |  |  |  | 
| 774 |  |  |  |  |  |  | sub _where_op_NEST { | 
| 775 | 26 |  |  | 26 |  | 55 | my ($self, $op, $v) = @_; | 
| 776 |  |  |  |  |  |  |  | 
| 777 |  |  |  |  |  |  | $self->_SWITCH_refkind($v, { | 
| 778 |  |  |  |  |  |  |  | 
| 779 |  |  |  |  |  |  | SCALAR => sub { # permissively interpreted as SQL | 
| 780 | 0 |  |  | 0 |  | 0 | belch "literal SQL should be -nest => \\'scalar' " | 
| 781 |  |  |  |  |  |  | . "instead of -nest => 'scalar' "; | 
| 782 | 0 |  |  |  |  | 0 | return ($v); | 
| 783 |  |  |  |  |  |  | }, | 
| 784 |  |  |  |  |  |  |  | 
| 785 |  |  |  |  |  |  | UNDEF => sub { | 
| 786 | 0 |  |  | 0 |  | 0 | puke "-$op => undef not supported"; | 
| 787 |  |  |  |  |  |  | }, | 
| 788 |  |  |  |  |  |  |  | 
| 789 |  |  |  |  |  |  | FALLBACK => sub { | 
| 790 | 26 |  |  | 26 |  | 48 | $self->_recurse_where($v); | 
| 791 |  |  |  |  |  |  | }, | 
| 792 |  |  |  |  |  |  |  | 
| 793 | 26 |  |  |  |  | 188 | }); | 
| 794 |  |  |  |  |  |  | } | 
| 795 |  |  |  |  |  |  |  | 
| 796 |  |  |  |  |  |  |  | 
| 797 |  |  |  |  |  |  | sub _where_op_BOOL { | 
| 798 | 24 |  |  | 24 |  | 45 | my ($self, $op, $v) = @_; | 
| 799 |  |  |  |  |  |  |  | 
| 800 |  |  |  |  |  |  | my ($s, @b) = $self->_SWITCH_refkind($v, { | 
| 801 |  |  |  |  |  |  | SCALAR => sub { # interpreted as SQL column | 
| 802 | 14 |  |  | 14 |  | 28 | $self->_convert($self->_quote($v)); | 
| 803 |  |  |  |  |  |  | }, | 
| 804 |  |  |  |  |  |  |  | 
| 805 |  |  |  |  |  |  | UNDEF => sub { | 
| 806 | 0 |  |  | 0 |  | 0 | puke "-$op => undef not supported"; | 
| 807 |  |  |  |  |  |  | }, | 
| 808 |  |  |  |  |  |  |  | 
| 809 |  |  |  |  |  |  | FALLBACK => sub { | 
| 810 | 10 |  |  | 10 |  | 21 | $self->_recurse_where($v); | 
| 811 |  |  |  |  |  |  | }, | 
| 812 | 24 |  |  |  |  | 169 | }); | 
| 813 |  |  |  |  |  |  |  | 
| 814 | 24 | 100 |  |  |  | 167 | $s = "(NOT $s)" if $op =~ /^not/i; | 
| 815 | 24 |  |  |  |  | 80 | ($s, @b); | 
| 816 |  |  |  |  |  |  | } | 
| 817 |  |  |  |  |  |  |  | 
| 818 |  |  |  |  |  |  |  | 
| 819 |  |  |  |  |  |  | sub _where_op_IDENT { | 
| 820 | 8 |  |  | 8 |  | 10 | my $self = shift; | 
| 821 | 8 |  |  |  |  | 18 | my ($op, $rhs) = splice @_, -2; | 
| 822 | 8 | 100 | 66 |  |  | 43 | if (! defined $rhs or length ref $rhs) { | 
| 823 | 2 |  |  |  |  | 8 | puke "-$op requires a single plain scalar argument (a quotable identifier)"; | 
| 824 |  |  |  |  |  |  | } | 
| 825 |  |  |  |  |  |  |  | 
| 826 |  |  |  |  |  |  | # in case we are called as a top level special op (no '=') | 
| 827 | 6 |  |  |  |  | 9 | my $lhs = shift; | 
| 828 |  |  |  |  |  |  |  | 
| 829 | 6 |  |  |  |  | 15 | $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs); | 
| 830 |  |  |  |  |  |  |  | 
| 831 | 6 | 100 |  |  |  | 23 | return $lhs | 
| 832 |  |  |  |  |  |  | ? "$lhs = $rhs" | 
| 833 |  |  |  |  |  |  | : $rhs | 
| 834 |  |  |  |  |  |  | ; | 
| 835 |  |  |  |  |  |  | } | 
| 836 |  |  |  |  |  |  |  | 
| 837 |  |  |  |  |  |  | sub _where_op_VALUE { | 
| 838 | 12 |  |  | 12 |  | 17 | my $self = shift; | 
| 839 | 12 |  |  |  |  | 27 | my ($op, $rhs) = splice @_, -2; | 
| 840 |  |  |  |  |  |  |  | 
| 841 |  |  |  |  |  |  | # in case we are called as a top level special op (no '=') | 
| 842 | 12 |  |  |  |  | 15 | my $lhs = shift; | 
| 843 |  |  |  |  |  |  |  | 
| 844 |  |  |  |  |  |  | # special-case NULL | 
| 845 | 12 | 100 |  |  |  | 33 | if (! defined $rhs) { | 
| 846 | 4 | 50 |  |  |  | 11 | return defined $lhs | 
| 847 |  |  |  |  |  |  | ? $self->_convert($self->_quote($lhs)) . ' IS NULL' | 
| 848 |  |  |  |  |  |  | : undef | 
| 849 |  |  |  |  |  |  | ; | 
| 850 |  |  |  |  |  |  | } | 
| 851 |  |  |  |  |  |  |  | 
| 852 |  |  |  |  |  |  | my @bind = | 
| 853 |  |  |  |  |  |  | $self->_bindtype( | 
| 854 | 8 | 100 |  |  |  | 30 | (defined $lhs ? $lhs : $self->{_nested_func_lhs}), | 
| 855 |  |  |  |  |  |  | $rhs, | 
| 856 |  |  |  |  |  |  | ) | 
| 857 |  |  |  |  |  |  | ; | 
| 858 |  |  |  |  |  |  |  | 
| 859 | 8 | 100 |  |  |  | 25 | return $lhs | 
| 860 |  |  |  |  |  |  | ? ( | 
| 861 |  |  |  |  |  |  | $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'), | 
| 862 |  |  |  |  |  |  | @bind | 
| 863 |  |  |  |  |  |  | ) | 
| 864 |  |  |  |  |  |  | : ( | 
| 865 |  |  |  |  |  |  | $self->_convert('?'), | 
| 866 |  |  |  |  |  |  | @bind, | 
| 867 |  |  |  |  |  |  | ) | 
| 868 |  |  |  |  |  |  | ; | 
| 869 |  |  |  |  |  |  | } | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | sub _where_hashpair_ARRAYREF { | 
| 872 | 46 |  |  | 46 |  | 94 | my ($self, $k, $v) = @_; | 
| 873 |  |  |  |  |  |  |  | 
| 874 | 46 | 100 |  |  |  | 97 | if (@$v) { | 
| 875 | 45 |  |  |  |  | 88 | my @v = @$v; # need copy because of shift below | 
| 876 | 45 |  |  |  |  | 138 | $self->_debug("ARRAY($k) means distribute over elements"); | 
| 877 |  |  |  |  |  |  |  | 
| 878 |  |  |  |  |  |  | # put apart first element if it is an operator (-and, -or) | 
| 879 | 45 | 100 | 66 |  |  | 272 | my $op = ( | 
| 880 |  |  |  |  |  |  | (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix) | 
| 881 |  |  |  |  |  |  | ? shift @v | 
| 882 |  |  |  |  |  |  | : '' | 
| 883 |  |  |  |  |  |  | ); | 
| 884 | 45 |  |  |  |  | 89 | my @distributed = map { {$k =>  $_} } @v; | 
|  | 104 |  |  |  |  | 228 |  | 
| 885 |  |  |  |  |  |  |  | 
| 886 | 45 | 100 |  |  |  | 109 | if ($op) { | 
| 887 | 22 |  |  |  |  | 62 | $self->_debug("OP($op) reinjected into the distributed array"); | 
| 888 | 22 |  |  |  |  | 43 | unshift @distributed, $op; | 
| 889 |  |  |  |  |  |  | } | 
| 890 |  |  |  |  |  |  |  | 
| 891 | 45 | 100 |  |  |  | 111 | my $logic = $op ? substr($op, 1) : ''; | 
| 892 |  |  |  |  |  |  |  | 
| 893 | 45 |  |  |  |  | 126 | return $self->_recurse_where(\@distributed, $logic); | 
| 894 |  |  |  |  |  |  | } | 
| 895 |  |  |  |  |  |  | else { | 
| 896 | 1 |  |  |  |  | 5 | $self->_debug("empty ARRAY($k) means 0=1"); | 
| 897 | 1 |  |  |  |  | 3 | return ($self->{sqlfalse}); | 
| 898 |  |  |  |  |  |  | } | 
| 899 |  |  |  |  |  |  | } | 
| 900 |  |  |  |  |  |  |  | 
| 901 |  |  |  |  |  |  | sub _where_hashpair_HASHREF { | 
| 902 | 583 |  |  | 583 |  | 1152 | my ($self, $k, $v, $logic) = @_; | 
| 903 | 583 |  | 100 |  |  | 1898 | $logic ||= 'and'; | 
| 904 |  |  |  |  |  |  |  | 
| 905 |  |  |  |  |  |  | local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs} | 
| 906 |  |  |  |  |  |  | ? $self->{_nested_func_lhs} | 
| 907 | 583 | 100 |  |  |  | 1537 | : $k | 
| 908 |  |  |  |  |  |  | ; | 
| 909 |  |  |  |  |  |  |  | 
| 910 | 583 |  |  |  |  | 831 | my ($all_sql, @all_bind); | 
| 911 |  |  |  |  |  |  |  | 
| 912 | 583 |  |  |  |  | 1385 | for my $orig_op (sort keys %$v) { | 
| 913 | 590 |  |  |  |  | 858 | my $val = $v->{$orig_op}; | 
| 914 |  |  |  |  |  |  |  | 
| 915 |  |  |  |  |  |  | # put the operator in canonical form | 
| 916 | 590 |  |  |  |  | 800 | my $op = $orig_op; | 
| 917 |  |  |  |  |  |  |  | 
| 918 |  |  |  |  |  |  | # FIXME - we need to phase out dash-less ops | 
| 919 | 590 |  |  |  |  | 1366 | $op =~ s/^-//;        # remove possible initial dash | 
| 920 | 590 |  |  |  |  | 1846 | $op =~ s/^\s+|\s+$//g;# remove leading/trailing space | 
| 921 | 590 |  |  |  |  | 1264 | $op =~ s/\s+/ /g;     # compress whitespace | 
| 922 |  |  |  |  |  |  |  | 
| 923 | 590 |  |  |  |  | 1329 | $self->_assert_pass_injection_guard($op); | 
| 924 |  |  |  |  |  |  |  | 
| 925 |  |  |  |  |  |  | # fixup is_not | 
| 926 | 588 |  |  |  |  | 1029 | $op =~ s/^is_not/IS NOT/i; | 
| 927 |  |  |  |  |  |  |  | 
| 928 |  |  |  |  |  |  | # so that -not_foo works correctly | 
| 929 | 588 |  |  |  |  | 800 | $op =~ s/^not_/NOT /i; | 
| 930 |  |  |  |  |  |  |  | 
| 931 |  |  |  |  |  |  | # another retarded special case: foo => { $op => { -value => undef } } | 
| 932 | 588 | 100 | 100 |  |  | 1478 | if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) { | 
|  |  |  | 100 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
| 933 | 28 |  |  |  |  | 45 | $val = undef; | 
| 934 |  |  |  |  |  |  | } | 
| 935 |  |  |  |  |  |  |  | 
| 936 | 588 |  |  |  |  | 747 | my ($sql, @bind); | 
| 937 |  |  |  |  |  |  |  | 
| 938 |  |  |  |  |  |  | # CASE: col-value logic modifiers | 
| 939 | 588 | 100 |  |  |  | 2194 | if ($orig_op =~ /^ \- (and|or) $/xi) { | 
|  |  | 100 |  |  |  |  |  | 
| 940 | 1 |  |  |  |  | 5 | ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1); | 
| 941 |  |  |  |  |  |  | } | 
| 942 |  |  |  |  |  |  | # CASE: special operators like -in or -between | 
| 943 | 2617 |  |  | 2617 |  | 7473 | elsif (my $special_op = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) { | 
|  | 587 |  |  |  |  | 1736 |  | 
| 944 | 137 |  |  |  |  | 276 | my $handler = $special_op->{handler}; | 
| 945 | 137 | 50 |  |  |  | 322 | if (! $handler) { | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 50 |  |  |  |  |  | 
| 946 | 0 |  |  |  |  | 0 | puke "No handler supplied for special operator $orig_op"; | 
| 947 |  |  |  |  |  |  | } | 
| 948 |  |  |  |  |  |  | elsif (not ref $handler) { | 
| 949 | 134 |  |  |  |  | 385 | ($sql, @bind) = $self->$handler($k, $op, $val); | 
| 950 |  |  |  |  |  |  | } | 
| 951 |  |  |  |  |  |  | elsif (ref $handler eq 'CODE') { | 
| 952 | 3 |  |  |  |  | 20 | ($sql, @bind) = $handler->($self, $k, $op, $val); | 
| 953 |  |  |  |  |  |  | } | 
| 954 |  |  |  |  |  |  | else { | 
| 955 | 0 |  |  |  |  | 0 | puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef"; | 
| 956 |  |  |  |  |  |  | } | 
| 957 |  |  |  |  |  |  | } | 
| 958 |  |  |  |  |  |  | else { | 
| 959 |  |  |  |  |  |  | $self->_SWITCH_refkind($val, { | 
| 960 |  |  |  |  |  |  |  | 
| 961 |  |  |  |  |  |  | ARRAYREF => sub {       # CASE: col => {op => \@vals} | 
| 962 | 149 |  |  | 149 |  | 321 | ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val); | 
| 963 |  |  |  |  |  |  | }, | 
| 964 |  |  |  |  |  |  |  | 
| 965 |  |  |  |  |  |  | ARRAYREFREF => sub {    # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind) | 
| 966 | 10 |  |  | 10 |  | 23 | my ($sub_sql, @sub_bind) = @$$val; | 
| 967 | 10 |  |  |  |  | 25 | $self->_assert_bindval_matches_bindtype(@sub_bind); | 
| 968 | 8 |  |  |  |  | 20 | $sql  = join ' ', $self->_convert($self->_quote($k)), | 
| 969 |  |  |  |  |  |  | $self->_sqlcase($op), | 
| 970 |  |  |  |  |  |  | $sub_sql; | 
| 971 | 8 |  |  |  |  | 23 | @bind = @sub_bind; | 
| 972 |  |  |  |  |  |  | }, | 
| 973 |  |  |  |  |  |  |  | 
| 974 |  |  |  |  |  |  | UNDEF => sub {          # CASE: col => {op => undef} : sql "IS (NOT)? NULL" | 
| 975 |  |  |  |  |  |  | my $is = | 
| 976 |  |  |  |  |  |  | $op =~ /^not$/i               ? 'is not'  # legacy | 
| 977 |  |  |  |  |  |  | : $op =~ $self->{equality_op}   ? 'is' | 
| 978 |  |  |  |  |  |  | : $op =~ $self->{like_op}       ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is' | 
| 979 |  |  |  |  |  |  | : $op =~ $self->{inequality_op} ? 'is not' | 
| 980 | 77 | 50 | 50 | 77 |  | 755 | : $op =~ $self->{not_like_op}   ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not' | 
|  |  | 100 | 50 |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 981 |  |  |  |  |  |  | : puke "unexpected operator '$orig_op' with undef operand"; | 
| 982 |  |  |  |  |  |  |  | 
| 983 | 77 |  |  |  |  | 57516 | $sql = $self->_quote($k) . $self->_sqlcase(" $is null"); | 
| 984 |  |  |  |  |  |  | }, | 
| 985 |  |  |  |  |  |  |  | 
| 986 |  |  |  |  |  |  | FALLBACK => sub {       # CASE: col => {op/func => $stuff} | 
| 987 | 214 |  |  | 214 |  | 521 | ($sql, @bind) = $self->_where_unary_op($op, $val); | 
| 988 |  |  |  |  |  |  |  | 
| 989 |  |  |  |  |  |  | $sql = join(' ', | 
| 990 |  |  |  |  |  |  | $self->_convert($self->_quote($k)), | 
| 991 | 212 | 50 |  |  |  | 421 | $self->{_nested_func_lhs} eq $k ? $sql : "($sql)",  # top level vs nested | 
| 992 |  |  |  |  |  |  | ); | 
| 993 |  |  |  |  |  |  | }, | 
| 994 | 450 |  |  |  |  | 4362 | }); | 
| 995 |  |  |  |  |  |  | } | 
| 996 |  |  |  |  |  |  |  | 
| 997 | 561 | 100 | 66 |  |  | 43786 | ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql; | 
| 998 | 561 |  |  |  |  | 1317 | push @all_bind, @bind; | 
| 999 |  |  |  |  |  |  | } | 
| 1000 | 554 |  |  |  |  | 1742 | return ($all_sql, @all_bind); | 
| 1001 |  |  |  |  |  |  | } | 
| 1002 |  |  |  |  |  |  |  | 
| 1003 |  |  |  |  |  |  | sub _where_field_IS { | 
| 1004 | 40 |  |  | 40 |  | 83 | my ($self, $k, $op, $v) = @_; | 
| 1005 |  |  |  |  |  |  |  | 
| 1006 |  |  |  |  |  |  | my ($s) = $self->_SWITCH_refkind($v, { | 
| 1007 |  |  |  |  |  |  | UNDEF => sub { | 
| 1008 |  |  |  |  |  |  | join ' ', | 
| 1009 |  |  |  |  |  |  | $self->_convert($self->_quote($k)), | 
| 1010 | 40 |  |  | 40 |  | 85 | map { $self->_sqlcase($_)} ($op, 'null') | 
|  | 80 |  |  |  |  | 122 |  | 
| 1011 |  |  |  |  |  |  | }, | 
| 1012 |  |  |  |  |  |  | FALLBACK => sub { | 
| 1013 | 0 |  |  | 0 |  | 0 | puke "$op can only take undef as argument"; | 
| 1014 |  |  |  |  |  |  | }, | 
| 1015 | 40 |  |  |  |  | 218 | }); | 
| 1016 |  |  |  |  |  |  |  | 
| 1017 | 40 |  |  |  |  | 220 | $s; | 
| 1018 |  |  |  |  |  |  | } | 
| 1019 |  |  |  |  |  |  |  | 
| 1020 |  |  |  |  |  |  | sub _where_field_op_ARRAYREF { | 
| 1021 | 149 |  |  | 149 |  | 333 | my ($self, $k, $op, $vals) = @_; | 
| 1022 |  |  |  |  |  |  |  | 
| 1023 | 149 |  |  |  |  | 290 | my @vals = @$vals;  #always work on a copy | 
| 1024 |  |  |  |  |  |  |  | 
| 1025 | 149 | 100 |  |  |  | 385 | if (@vals) { | 
| 1026 |  |  |  |  |  |  | $self->_debug(sprintf '%s means multiple elements: [ %s ]', | 
| 1027 |  |  |  |  |  |  | $vals, | 
| 1028 | 106 | 100 |  |  |  | 204 | join(', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ), | 
|  | 152 |  |  |  |  | 826 |  | 
| 1029 |  |  |  |  |  |  | ); | 
| 1030 |  |  |  |  |  |  |  | 
| 1031 |  |  |  |  |  |  | # see if the first element is an -and/-or op | 
| 1032 | 106 |  |  |  |  | 146 | my $logic; | 
| 1033 | 106 | 100 | 100 |  |  | 349 | if (defined $vals[0] && $vals[0] =~ /^ - (AND|OR) $/ix) { | 
| 1034 | 2 |  |  |  |  | 9 | $logic = uc $1; | 
| 1035 | 2 |  |  |  |  | 4 | shift @vals; | 
| 1036 |  |  |  |  |  |  | } | 
| 1037 |  |  |  |  |  |  |  | 
| 1038 |  |  |  |  |  |  | # a long standing API wart - an attempt to change this behavior during | 
| 1039 |  |  |  |  |  |  | # the 1.50 series failed *spectacularly*. Warn instead and leave the | 
| 1040 |  |  |  |  |  |  | # behavior as is | 
| 1041 | 106 | 100 | 66 |  |  | 592 | if ( | 
|  |  |  | 100 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
| 1042 |  |  |  |  |  |  | @vals > 1 | 
| 1043 |  |  |  |  |  |  | and | 
| 1044 |  |  |  |  |  |  | (!$logic or $logic eq 'OR') | 
| 1045 |  |  |  |  |  |  | and | 
| 1046 |  |  |  |  |  |  | ($op =~ $self->{inequality_op} or $op =~ $self->{not_like_op}) | 
| 1047 |  |  |  |  |  |  | ) { | 
| 1048 | 36 |  |  |  |  | 83 | my $o = uc($op); | 
| 1049 | 36 |  |  |  |  | 127 | belch "A multi-element arrayref as an argument to the inequality op '$o' " | 
| 1050 |  |  |  |  |  |  | . 'is technically equivalent to an always-true 1=1 (you probably wanted ' | 
| 1051 |  |  |  |  |  |  | . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)" | 
| 1052 |  |  |  |  |  |  | ; | 
| 1053 |  |  |  |  |  |  | } | 
| 1054 |  |  |  |  |  |  |  | 
| 1055 |  |  |  |  |  |  | # distribute $op over each remaining member of @vals, append logic if exists | 
| 1056 | 106 |  |  |  |  | 35477 | return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic); | 
|  | 150 |  |  |  |  | 610 |  | 
| 1057 |  |  |  |  |  |  |  | 
| 1058 |  |  |  |  |  |  | } | 
| 1059 |  |  |  |  |  |  | else { | 
| 1060 |  |  |  |  |  |  | # try to DWIM on equality operators | 
| 1061 |  |  |  |  |  |  | return | 
| 1062 |  |  |  |  |  |  | $op =~ $self->{equality_op}   ? $self->{sqlfalse} | 
| 1063 |  |  |  |  |  |  | : $op =~ $self->{like_op}       ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse} | 
| 1064 |  |  |  |  |  |  | : $op =~ $self->{inequality_op} ? $self->{sqltrue} | 
| 1065 |  |  |  |  |  |  | : $op =~ $self->{not_like_op}   ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue} | 
| 1066 | 43 | 100 | 33 |  |  | 488 | : puke "operator '$op' applied on an empty array (field '$k')"; | 
|  |  | 100 | 33 |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 50 |  |  |  |  |  | 
| 1067 |  |  |  |  |  |  | } | 
| 1068 |  |  |  |  |  |  | } | 
| 1069 |  |  |  |  |  |  |  | 
| 1070 |  |  |  |  |  |  |  | 
| 1071 |  |  |  |  |  |  | sub _where_hashpair_SCALARREF { | 
| 1072 | 32 |  |  | 32 |  | 77 | my ($self, $k, $v) = @_; | 
| 1073 | 32 |  |  |  |  | 133 | $self->_debug("SCALAR($k) means literal SQL: $$v"); | 
| 1074 | 32 |  |  |  |  | 83 | my $sql = $self->_quote($k) . " " . $$v; | 
| 1075 | 32 |  |  |  |  | 88 | return ($sql); | 
| 1076 |  |  |  |  |  |  | } | 
| 1077 |  |  |  |  |  |  |  | 
| 1078 |  |  |  |  |  |  | # literal SQL with bind | 
| 1079 |  |  |  |  |  |  | sub _where_hashpair_ARRAYREFREF { | 
| 1080 | 27 |  |  | 27 |  | 57 | my ($self, $k, $v) = @_; | 
| 1081 | 27 |  |  |  |  | 71 | $self->_debug("REF($k) means literal SQL: @${$v}"); | 
|  | 27 |  |  |  |  | 112 |  | 
| 1082 | 27 |  |  |  |  | 68 | my ($sql, @bind) = @$$v; | 
| 1083 | 27 |  |  |  |  | 79 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1084 | 25 |  |  |  |  | 56 | $sql  = $self->_quote($k) . " " . $sql; | 
| 1085 | 25 |  |  |  |  | 81 | return ($sql, @bind ); | 
| 1086 |  |  |  |  |  |  | } | 
| 1087 |  |  |  |  |  |  |  | 
| 1088 |  |  |  |  |  |  | # literal SQL without bind | 
| 1089 |  |  |  |  |  |  | sub _where_hashpair_SCALAR { | 
| 1090 | 440 |  |  | 440 |  | 689 | my ($self, $k, $v) = @_; | 
| 1091 | 440 |  |  |  |  | 1419 | $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v"); | 
| 1092 |  |  |  |  |  |  | my $sql = join ' ', $self->_convert($self->_quote($k)), | 
| 1093 | 440 |  |  |  |  | 848 | $self->_sqlcase($self->{cmp}), | 
| 1094 |  |  |  |  |  |  | $self->_convert('?'); | 
| 1095 | 439 |  |  |  |  | 974 | my @bind =  $self->_bindtype($k, $v); | 
| 1096 | 439 |  |  |  |  | 1183 | return ($sql, @bind); | 
| 1097 |  |  |  |  |  |  | } | 
| 1098 |  |  |  |  |  |  |  | 
| 1099 |  |  |  |  |  |  |  | 
| 1100 |  |  |  |  |  |  | sub _where_hashpair_UNDEF { | 
| 1101 | 16 |  |  | 16 |  | 38 | my ($self, $k, $v) = @_; | 
| 1102 | 16 |  |  |  |  | 48 | $self->_debug("UNDEF($k) means IS NULL"); | 
| 1103 | 16 |  |  |  |  | 53 | my $sql = $self->_quote($k) . $self->_sqlcase(' is null'); | 
| 1104 | 16 |  |  |  |  | 46 | return ($sql); | 
| 1105 |  |  |  |  |  |  | } | 
| 1106 |  |  |  |  |  |  |  | 
| 1107 |  |  |  |  |  |  | #====================================================================== | 
| 1108 |  |  |  |  |  |  | # WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF) | 
| 1109 |  |  |  |  |  |  | #====================================================================== | 
| 1110 |  |  |  |  |  |  |  | 
| 1111 |  |  |  |  |  |  |  | 
| 1112 |  |  |  |  |  |  | sub _where_SCALARREF { | 
| 1113 | 6 |  |  | 6 |  | 14 | my ($self, $where) = @_; | 
| 1114 |  |  |  |  |  |  |  | 
| 1115 |  |  |  |  |  |  | # literal sql | 
| 1116 | 6 |  |  |  |  | 23 | $self->_debug("SCALAR(*top) means literal SQL: $$where"); | 
| 1117 | 6 |  |  |  |  | 15 | return ($$where); | 
| 1118 |  |  |  |  |  |  | } | 
| 1119 |  |  |  |  |  |  |  | 
| 1120 |  |  |  |  |  |  |  | 
| 1121 |  |  |  |  |  |  | sub _where_SCALAR { | 
| 1122 | 0 |  |  | 0 |  | 0 | my ($self, $where) = @_; | 
| 1123 |  |  |  |  |  |  |  | 
| 1124 |  |  |  |  |  |  | # literal sql | 
| 1125 | 0 |  |  |  |  | 0 | $self->_debug("NOREF(*top) means literal SQL: $where"); | 
| 1126 | 0 |  |  |  |  | 0 | return ($where); | 
| 1127 |  |  |  |  |  |  | } | 
| 1128 |  |  |  |  |  |  |  | 
| 1129 |  |  |  |  |  |  |  | 
| 1130 |  |  |  |  |  |  | sub _where_UNDEF { | 
| 1131 | 46 |  |  | 46 |  | 67 | my ($self) = @_; | 
| 1132 | 46 |  |  |  |  | 71 | return (); | 
| 1133 |  |  |  |  |  |  | } | 
| 1134 |  |  |  |  |  |  |  | 
| 1135 |  |  |  |  |  |  |  | 
| 1136 |  |  |  |  |  |  | #====================================================================== | 
| 1137 |  |  |  |  |  |  | # WHERE: BUILTIN SPECIAL OPERATORS (-in, -between) | 
| 1138 |  |  |  |  |  |  | #====================================================================== | 
| 1139 |  |  |  |  |  |  |  | 
| 1140 |  |  |  |  |  |  |  | 
| 1141 |  |  |  |  |  |  | sub _where_field_BETWEEN { | 
| 1142 | 45 |  |  | 45 |  | 104 | my ($self, $k, $op, $vals) = @_; | 
| 1143 |  |  |  |  |  |  |  | 
| 1144 | 45 |  |  |  |  | 67 | my ($label, $and, $placeholder); | 
| 1145 | 45 |  |  |  |  | 97 | $label       = $self->_convert($self->_quote($k)); | 
| 1146 | 45 |  |  |  |  | 95 | $and         = ' ' . $self->_sqlcase('and') . ' '; | 
| 1147 | 45 |  |  |  |  | 123 | $placeholder = $self->_convert('?'); | 
| 1148 | 45 |  |  |  |  | 77 | $op               = $self->_sqlcase($op); | 
| 1149 |  |  |  |  |  |  |  | 
| 1150 | 45 |  |  |  |  | 96 | my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"; | 
| 1151 |  |  |  |  |  |  |  | 
| 1152 |  |  |  |  |  |  | my ($clause, @bind) = $self->_SWITCH_refkind($vals, { | 
| 1153 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 1154 | 5 |  |  | 5 |  | 11 | my ($s, @b) = @$$vals; | 
| 1155 | 5 |  |  |  |  | 12 | $self->_assert_bindval_matches_bindtype(@b); | 
| 1156 | 5 |  |  |  |  | 13 | ($s, @b); | 
| 1157 |  |  |  |  |  |  | }, | 
| 1158 |  |  |  |  |  |  | SCALARREF => sub { | 
| 1159 | 3 |  |  | 3 |  | 30 | return $$vals; | 
| 1160 |  |  |  |  |  |  | }, | 
| 1161 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 1162 | 35 | 100 |  | 35 |  | 141 | puke $invalid_args if @$vals != 2; | 
| 1163 |  |  |  |  |  |  |  | 
| 1164 | 28 |  |  |  |  | 48 | my (@all_sql, @all_bind); | 
| 1165 | 28 |  |  |  |  | 53 | foreach my $val (@$vals) { | 
| 1166 |  |  |  |  |  |  | my ($sql, @bind) = $self->_SWITCH_refkind($val, { | 
| 1167 |  |  |  |  |  |  | SCALAR => sub { | 
| 1168 | 39 |  |  |  |  | 77 | return ($placeholder, $self->_bindtype($k, $val) ); | 
| 1169 |  |  |  |  |  |  | }, | 
| 1170 |  |  |  |  |  |  | SCALARREF => sub { | 
| 1171 | 6 |  |  |  |  | 21 | return $$val; | 
| 1172 |  |  |  |  |  |  | }, | 
| 1173 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 1174 | 4 |  |  |  |  | 11 | my ($sql, @bind) = @$$val; | 
| 1175 | 4 |  |  |  |  | 12 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1176 | 4 |  |  |  |  | 11 | return ($sql, @bind); | 
| 1177 |  |  |  |  |  |  | }, | 
| 1178 |  |  |  |  |  |  | HASHREF => sub { | 
| 1179 | 2 |  |  |  |  | 6 | my ($func, $arg, @rest) = %$val; | 
| 1180 | 2 | 50 | 33 |  |  | 14 | puke "Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN" | 
| 1181 |  |  |  |  |  |  | if (@rest or $func !~ /^ \- (.+)/x); | 
| 1182 | 2 |  |  |  |  | 8 | $self->_where_unary_op($1 => $arg); | 
| 1183 |  |  |  |  |  |  | }, | 
| 1184 |  |  |  |  |  |  | FALLBACK => sub { | 
| 1185 | 3 |  |  |  |  | 7 | puke $invalid_args, | 
| 1186 |  |  |  |  |  |  | }, | 
| 1187 | 54 |  |  |  |  | 438 | }); | 
| 1188 | 51 |  |  |  |  | 311 | push @all_sql, $sql; | 
| 1189 | 51 |  |  |  |  | 104 | push @all_bind, @bind; | 
| 1190 |  |  |  |  |  |  | } | 
| 1191 |  |  |  |  |  |  |  | 
| 1192 |  |  |  |  |  |  | return ( | 
| 1193 | 25 |  |  |  |  | 95 | (join $and, @all_sql), | 
| 1194 |  |  |  |  |  |  | @all_bind | 
| 1195 |  |  |  |  |  |  | ); | 
| 1196 |  |  |  |  |  |  | }, | 
| 1197 |  |  |  |  |  |  | FALLBACK => sub { | 
| 1198 | 2 |  |  | 2 |  | 3 | puke $invalid_args, | 
| 1199 |  |  |  |  |  |  | }, | 
| 1200 | 45 |  |  |  |  | 440 | }); | 
| 1201 |  |  |  |  |  |  |  | 
| 1202 | 33 |  |  |  |  | 294 | my $sql = "( $label $op $clause )"; | 
| 1203 | 33 |  |  |  |  | 96 | return ($sql, @bind) | 
| 1204 |  |  |  |  |  |  | } | 
| 1205 |  |  |  |  |  |  |  | 
| 1206 |  |  |  |  |  |  |  | 
| 1207 |  |  |  |  |  |  | sub _where_field_IN { | 
| 1208 | 37 |  |  | 37 |  | 135 | my ($self, $k, $op, $vals) = @_; | 
| 1209 |  |  |  |  |  |  |  | 
| 1210 |  |  |  |  |  |  | # backwards compatibility: if scalar, force into an arrayref | 
| 1211 | 37 | 100 | 100 |  |  | 197 | $vals = [$vals] if defined $vals && ! ref $vals; | 
| 1212 |  |  |  |  |  |  |  | 
| 1213 | 37 |  |  |  |  | 101 | my ($label)       = $self->_convert($self->_quote($k)); | 
| 1214 | 37 |  |  |  |  | 80 | my ($placeholder) = $self->_convert('?'); | 
| 1215 | 37 |  |  |  |  | 72 | $op               = $self->_sqlcase($op); | 
| 1216 |  |  |  |  |  |  |  | 
| 1217 |  |  |  |  |  |  | my ($sql, @bind) = $self->_SWITCH_refkind($vals, { | 
| 1218 |  |  |  |  |  |  | ARRAYREF => sub {     # list of choices | 
| 1219 | 25 | 100 |  | 25 |  | 74 | if (@$vals) { # nonempty list | 
| 1220 | 22 |  |  |  |  | 91 | my (@all_sql, @all_bind); | 
| 1221 |  |  |  |  |  |  |  | 
| 1222 | 22 |  |  |  |  | 69 | for my $val (@$vals) { | 
| 1223 |  |  |  |  |  |  | my ($sql, @bind) = $self->_SWITCH_refkind($val, { | 
| 1224 |  |  |  |  |  |  | SCALAR => sub { | 
| 1225 | 57 |  |  |  |  | 120 | return ($placeholder, $val); | 
| 1226 |  |  |  |  |  |  | }, | 
| 1227 |  |  |  |  |  |  | SCALARREF => sub { | 
| 1228 | 1 |  |  |  |  | 4 | return $$val; | 
| 1229 |  |  |  |  |  |  | }, | 
| 1230 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 1231 | 1 |  |  |  |  | 3 | my ($sql, @bind) = @$$val; | 
| 1232 | 1 |  |  |  |  | 5 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1233 | 1 |  |  |  |  | 2 | return ($sql, @bind); | 
| 1234 |  |  |  |  |  |  | }, | 
| 1235 |  |  |  |  |  |  | HASHREF => sub { | 
| 1236 | 1 |  |  |  |  | 3 | my ($func, $arg, @rest) = %$val; | 
| 1237 | 1 | 50 | 33 |  |  | 7 | puke "Only simple { -func => arg } functions accepted as sub-arguments to IN" | 
| 1238 |  |  |  |  |  |  | if (@rest or $func !~ /^ \- (.+)/x); | 
| 1239 | 1 |  |  |  |  | 6 | $self->_where_unary_op($1 => $arg); | 
| 1240 |  |  |  |  |  |  | }, | 
| 1241 |  |  |  |  |  |  | UNDEF => sub { | 
| 1242 | 4 |  |  |  |  | 19 | puke( | 
| 1243 |  |  |  |  |  |  | 'SQL::Abstract before v1.75 used to generate incorrect SQL when the ' | 
| 1244 |  |  |  |  |  |  | . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE " | 
| 1245 |  |  |  |  |  |  | . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract ' | 
| 1246 |  |  |  |  |  |  | . 'will emit the logically correct SQL instead of raising this exception)' | 
| 1247 |  |  |  |  |  |  | ); | 
| 1248 |  |  |  |  |  |  | }, | 
| 1249 | 64 |  |  |  |  | 424 | }); | 
| 1250 | 60 |  |  |  |  | 345 | push @all_sql, $sql; | 
| 1251 | 60 |  |  |  |  | 106 | push @all_bind, @bind; | 
| 1252 |  |  |  |  |  |  | } | 
| 1253 |  |  |  |  |  |  |  | 
| 1254 |  |  |  |  |  |  | return ( | 
| 1255 | 18 |  |  |  |  | 118 | sprintf('%s %s ( %s )', | 
| 1256 |  |  |  |  |  |  | $label, | 
| 1257 |  |  |  |  |  |  | $op, | 
| 1258 |  |  |  |  |  |  | join(', ', @all_sql) | 
| 1259 |  |  |  |  |  |  | ), | 
| 1260 |  |  |  |  |  |  | $self->_bindtype($k, @all_bind), | 
| 1261 |  |  |  |  |  |  | ); | 
| 1262 |  |  |  |  |  |  | } | 
| 1263 |  |  |  |  |  |  | else { # empty list: some databases won't understand "IN ()", so DWIM | 
| 1264 | 3 | 100 |  |  |  | 10 | my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse}; | 
| 1265 | 3 |  |  |  |  | 7 | return ($sql); | 
| 1266 |  |  |  |  |  |  | } | 
| 1267 |  |  |  |  |  |  | }, | 
| 1268 |  |  |  |  |  |  |  | 
| 1269 |  |  |  |  |  |  | SCALARREF => sub {  # literal SQL | 
| 1270 | 4 |  |  | 4 |  | 8 | my $sql = $self->_open_outer_paren($$vals); | 
| 1271 | 4 |  |  |  |  | 18 | return ("$label $op ( $sql )"); | 
| 1272 |  |  |  |  |  |  | }, | 
| 1273 |  |  |  |  |  |  | ARRAYREFREF => sub {  # literal SQL with bind | 
| 1274 | 7 |  |  | 7 |  | 29 | my ($sql, @bind) = @$$vals; | 
| 1275 | 7 |  |  |  |  | 23 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1276 | 5 |  |  |  |  | 14 | $sql = $self->_open_outer_paren($sql); | 
| 1277 | 5 |  |  |  |  | 24 | return ("$label $op ( $sql )", @bind); | 
| 1278 |  |  |  |  |  |  | }, | 
| 1279 |  |  |  |  |  |  |  | 
| 1280 |  |  |  |  |  |  | UNDEF => sub { | 
| 1281 | 1 |  |  | 1 |  | 4 | puke "Argument passed to the '$op' operator can not be undefined"; | 
| 1282 |  |  |  |  |  |  | }, | 
| 1283 |  |  |  |  |  |  |  | 
| 1284 |  |  |  |  |  |  | FALLBACK => sub { | 
| 1285 | 0 |  |  | 0 |  | 0 | puke "special op $op requires an arrayref (or scalarref/arrayref-ref)"; | 
| 1286 |  |  |  |  |  |  | }, | 
| 1287 | 37 |  |  |  |  | 471 | }); | 
| 1288 |  |  |  |  |  |  |  | 
| 1289 | 30 |  |  |  |  | 391 | return ($sql, @bind); | 
| 1290 |  |  |  |  |  |  | } | 
| 1291 |  |  |  |  |  |  |  | 
| 1292 |  |  |  |  |  |  | # Some databases (SQLite) treat col IN (1, 2) different from | 
| 1293 |  |  |  |  |  |  | # col IN ( (1, 2) ). Use this to strip all outer parens while | 
| 1294 |  |  |  |  |  |  | # adding them back in the corresponding method | 
| 1295 |  |  |  |  |  |  | sub _open_outer_paren { | 
| 1296 | 9 |  |  | 9 |  | 19 | my ($self, $sql) = @_; | 
| 1297 |  |  |  |  |  |  |  | 
| 1298 | 9 |  |  |  |  | 49 | while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) { | 
| 1299 |  |  |  |  |  |  |  | 
| 1300 |  |  |  |  |  |  | # there are closing parens inside, need the heavy duty machinery | 
| 1301 |  |  |  |  |  |  | # to reevaluate the extraction starting from $sql (full reevaluation) | 
| 1302 | 7 | 100 |  |  |  | 20 | if ($inner =~ /\)/) { | 
| 1303 | 6 |  |  |  |  | 1754 | require Text::Balanced; | 
| 1304 |  |  |  |  |  |  |  | 
| 1305 | 6 |  |  |  |  | 28756 | my (undef, $remainder) = do { | 
| 1306 |  |  |  |  |  |  | # idiotic design - writes to $@ but *DOES NOT* throw exceptions | 
| 1307 | 6 |  |  |  |  | 8 | local $@; | 
| 1308 | 6 |  |  |  |  | 40 | Text::Balanced::extract_bracketed($sql, '()', qr/\s*/); | 
| 1309 |  |  |  |  |  |  | }; | 
| 1310 |  |  |  |  |  |  |  | 
| 1311 |  |  |  |  |  |  | # the entire expression needs to be a balanced bracketed thing | 
| 1312 |  |  |  |  |  |  | # (after an extract no remainder sans trailing space) | 
| 1313 | 6 | 100 | 66 |  |  | 1065 | last if defined $remainder and $remainder =~ /\S/; | 
| 1314 |  |  |  |  |  |  | } | 
| 1315 |  |  |  |  |  |  |  | 
| 1316 | 6 |  |  |  |  | 30 | $sql = $inner; | 
| 1317 |  |  |  |  |  |  | } | 
| 1318 |  |  |  |  |  |  |  | 
| 1319 | 9 |  |  |  |  | 21 | $sql; | 
| 1320 |  |  |  |  |  |  | } | 
| 1321 |  |  |  |  |  |  |  | 
| 1322 |  |  |  |  |  |  |  | 
| 1323 |  |  |  |  |  |  | #====================================================================== | 
| 1324 |  |  |  |  |  |  | # ORDER BY | 
| 1325 |  |  |  |  |  |  | #====================================================================== | 
| 1326 |  |  |  |  |  |  |  | 
| 1327 |  |  |  |  |  |  | sub _order_by { | 
| 1328 | 52 |  |  | 52 |  | 1137 | my ($self, $arg) = @_; | 
| 1329 |  |  |  |  |  |  |  | 
| 1330 | 52 |  |  |  |  | 70 | my (@sql, @bind); | 
| 1331 | 52 |  |  |  |  | 97 | for my $c ($self->_order_by_chunks($arg) ) { | 
| 1332 |  |  |  |  |  |  | $self->_SWITCH_refkind($c, { | 
| 1333 | 38 |  |  | 38 |  | 152 | SCALAR => sub { push @sql, $c }, | 
| 1334 | 52 |  |  | 52 |  | 77 | ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c }, | 
|  | 52 |  |  |  |  | 157 |  | 
| 1335 | 90 |  |  |  |  | 382 | }); | 
| 1336 |  |  |  |  |  |  | } | 
| 1337 |  |  |  |  |  |  |  | 
| 1338 | 50 | 100 |  |  |  | 389 | my $sql = @sql | 
| 1339 |  |  |  |  |  |  | ? sprintf('%s %s', | 
| 1340 |  |  |  |  |  |  | $self->_sqlcase(' order by'), | 
| 1341 |  |  |  |  |  |  | join(', ', @sql) | 
| 1342 |  |  |  |  |  |  | ) | 
| 1343 |  |  |  |  |  |  | : '' | 
| 1344 |  |  |  |  |  |  | ; | 
| 1345 |  |  |  |  |  |  |  | 
| 1346 | 50 | 50 |  |  |  | 166 | return wantarray ? ($sql, @bind) : $sql; | 
| 1347 |  |  |  |  |  |  | } | 
| 1348 |  |  |  |  |  |  |  | 
| 1349 |  |  |  |  |  |  | sub _order_by_chunks { | 
| 1350 | 177 |  |  | 177 |  | 239 | my ($self, $arg) = @_; | 
| 1351 |  |  |  |  |  |  |  | 
| 1352 |  |  |  |  |  |  | return $self->_SWITCH_refkind($arg, { | 
| 1353 |  |  |  |  |  |  |  | 
| 1354 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 1355 | 47 |  |  | 47 |  | 109 | map { $self->_order_by_chunks($_ ) } @$arg; | 
|  | 87 |  |  |  |  | 159 |  | 
| 1356 |  |  |  |  |  |  | }, | 
| 1357 |  |  |  |  |  |  |  | 
| 1358 |  |  |  |  |  |  | ARRAYREFREF => sub { | 
| 1359 | 10 |  |  | 10 |  | 22 | my ($s, @b) = @$$arg; | 
| 1360 | 10 |  |  |  |  | 21 | $self->_assert_bindval_matches_bindtype(@b); | 
| 1361 | 10 |  |  |  |  | 26 | [ $s, @b ]; | 
| 1362 |  |  |  |  |  |  | }, | 
| 1363 |  |  |  |  |  |  |  | 
| 1364 | 76 |  |  | 76 |  | 127 | SCALAR    => sub {$self->_quote($arg)}, | 
| 1365 |  |  |  |  |  |  |  | 
| 1366 | 0 |  |  | 0 |  | 0 | UNDEF     => sub {return () }, | 
| 1367 |  |  |  |  |  |  |  | 
| 1368 | 4 |  |  | 4 |  | 11 | SCALARREF => sub {$$arg}, # literal SQL, no quoting | 
| 1369 |  |  |  |  |  |  |  | 
| 1370 |  |  |  |  |  |  | HASHREF   => sub { | 
| 1371 |  |  |  |  |  |  | # get first pair in hash | 
| 1372 | 40 |  |  | 40 |  | 101 | my ($key, $val, @rest) = %$arg; | 
| 1373 |  |  |  |  |  |  |  | 
| 1374 | 40 | 50 |  |  |  | 66 | return () unless $key; | 
| 1375 |  |  |  |  |  |  |  | 
| 1376 | 40 | 100 | 66 |  |  | 205 | if (@rest or not $key =~ /^-(desc|asc)/i) { | 
| 1377 | 2 |  |  |  |  | 7 | puke "hash passed to _order_by must have exactly one key (-desc or -asc)"; | 
| 1378 |  |  |  |  |  |  | } | 
| 1379 |  |  |  |  |  |  |  | 
| 1380 | 38 |  |  |  |  | 93 | my $direction = $1; | 
| 1381 |  |  |  |  |  |  |  | 
| 1382 | 38 |  |  |  |  | 43 | my @ret; | 
| 1383 | 38 |  |  |  |  | 57 | for my $c ($self->_order_by_chunks($val)) { | 
| 1384 | 50 |  |  |  |  | 65 | my ($sql, @bind); | 
| 1385 |  |  |  |  |  |  |  | 
| 1386 |  |  |  |  |  |  | $self->_SWITCH_refkind($c, { | 
| 1387 |  |  |  |  |  |  | SCALAR => sub { | 
| 1388 | 42 |  |  |  |  | 57 | $sql = $c; | 
| 1389 |  |  |  |  |  |  | }, | 
| 1390 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 1391 | 8 |  |  |  |  | 19 | ($sql, @bind) = @$c; | 
| 1392 |  |  |  |  |  |  | }, | 
| 1393 | 50 |  |  |  |  | 231 | }); | 
| 1394 |  |  |  |  |  |  |  | 
| 1395 | 50 |  |  |  |  | 184 | $sql = $sql . ' ' . $self->_sqlcase($direction); | 
| 1396 |  |  |  |  |  |  |  | 
| 1397 | 50 |  |  |  |  | 112 | push @ret, [ $sql, @bind]; | 
| 1398 |  |  |  |  |  |  | } | 
| 1399 |  |  |  |  |  |  |  | 
| 1400 | 38 |  |  |  |  | 429 | return @ret; | 
| 1401 |  |  |  |  |  |  | }, | 
| 1402 | 177 |  |  |  |  | 1633 | }); | 
| 1403 |  |  |  |  |  |  | } | 
| 1404 |  |  |  |  |  |  |  | 
| 1405 |  |  |  |  |  |  |  | 
| 1406 |  |  |  |  |  |  | #====================================================================== | 
| 1407 |  |  |  |  |  |  | # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES) | 
| 1408 |  |  |  |  |  |  | #====================================================================== | 
| 1409 |  |  |  |  |  |  |  | 
| 1410 |  |  |  |  |  |  | sub _table  { | 
| 1411 | 199 |  |  | 199 |  | 240 | my $self = shift; | 
| 1412 | 199 |  |  |  |  | 282 | my $from = shift; | 
| 1413 |  |  |  |  |  |  | $self->_SWITCH_refkind($from, { | 
| 1414 | 4 |  |  | 4 |  | 7 | ARRAYREF     => sub {join ', ', map { $self->_quote($_) } @$from;}, | 
|  | 10 |  |  |  |  | 16 |  | 
| 1415 | 195 |  |  | 195 |  | 369 | SCALAR       => sub {$self->_quote($from)}, | 
| 1416 | 0 |  |  | 0 |  | 0 | SCALARREF    => sub {$$from}, | 
| 1417 | 199 |  |  |  |  | 1266 | }); | 
| 1418 |  |  |  |  |  |  | } | 
| 1419 |  |  |  |  |  |  |  | 
| 1420 |  |  |  |  |  |  |  | 
| 1421 |  |  |  |  |  |  | #====================================================================== | 
| 1422 |  |  |  |  |  |  | # UTILITY FUNCTIONS | 
| 1423 |  |  |  |  |  |  | #====================================================================== | 
| 1424 |  |  |  |  |  |  |  | 
| 1425 |  |  |  |  |  |  | # highly optimized, as it's called way too often | 
| 1426 |  |  |  |  |  |  | sub _quote { | 
| 1427 |  |  |  |  |  |  | # my ($self, $label) = @_; | 
| 1428 |  |  |  |  |  |  |  | 
| 1429 | 1462 | 100 |  | 1462 |  | 2502 | return '' unless defined $_[1]; | 
| 1430 | 1458 | 100 |  |  |  | 2276 | return ${$_[1]} if ref($_[1]) eq 'SCALAR'; | 
|  | 2 |  |  |  |  | 5 |  | 
| 1431 |  |  |  |  |  |  |  | 
| 1432 |  |  |  |  |  |  | $_[0]->{quote_char} or | 
| 1433 | 1456 | 100 |  |  |  | 3103 | ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]); | 
| 1434 |  |  |  |  |  |  |  | 
| 1435 | 484 |  |  |  |  | 740 | my $qref = ref $_[0]->{quote_char}; | 
| 1436 |  |  |  |  |  |  | my ($l, $r) = | 
| 1437 |  |  |  |  |  |  | !$qref             ? ($_[0]->{quote_char}, $_[0]->{quote_char}) | 
| 1438 | 484 | 0 |  |  |  | 1111 | : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}} | 
|  | 0 | 50 |  |  |  | 0 |  | 
| 1439 |  |  |  |  |  |  | : puke "Unsupported quote_char format: $_[0]->{quote_char}"; | 
| 1440 |  |  |  |  |  |  |  | 
| 1441 | 484 |  | 66 |  |  | 1350 | my $esc = $_[0]->{escape_char} || $r; | 
| 1442 |  |  |  |  |  |  |  | 
| 1443 |  |  |  |  |  |  | # parts containing * are naturally unquoted | 
| 1444 |  |  |  |  |  |  | return join($_[0]->{name_sep}||'', map | 
| 1445 | 487 |  |  |  |  | 1701 | +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ), | 
|  | 487 |  |  |  |  | 2156 |  | 
| 1446 | 484 | 50 | 100 |  |  | 2282 | ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] ) | 
|  |  | 100 |  |  |  |  |  | 
| 1447 |  |  |  |  |  |  | ); | 
| 1448 |  |  |  |  |  |  | } | 
| 1449 |  |  |  |  |  |  |  | 
| 1450 |  |  |  |  |  |  |  | 
| 1451 |  |  |  |  |  |  | # Conversion, if applicable | 
| 1452 |  |  |  |  |  |  | sub _convert { | 
| 1453 |  |  |  |  |  |  | #my ($self, $arg) = @_; | 
| 1454 | 1553 | 100 |  | 1553 |  | 2739 | if ($_[0]->{convert}) { | 
| 1455 | 38 |  |  |  |  | 52 | return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')'; | 
| 1456 |  |  |  |  |  |  | } | 
| 1457 | 1515 |  |  |  |  | 3187 | return $_[1]; | 
| 1458 |  |  |  |  |  |  | } | 
| 1459 |  |  |  |  |  |  |  | 
| 1460 |  |  |  |  |  |  | # And bindtype | 
| 1461 |  |  |  |  |  |  | sub _bindtype { | 
| 1462 |  |  |  |  |  |  | #my ($self, $col, @vals) = @_; | 
| 1463 |  |  |  |  |  |  | # called often - tighten code | 
| 1464 |  |  |  |  |  |  | return $_[0]->{bindtype} eq 'columns' | 
| 1465 | 1043 | 100 |  | 1043 |  | 3838 | ? map {[$_[1], $_]} @_[2 .. $#_] | 
|  | 100 |  |  |  |  | 449 |  | 
| 1466 |  |  |  |  |  |  | : @_[2 .. $#_] | 
| 1467 |  |  |  |  |  |  | ; | 
| 1468 |  |  |  |  |  |  | } | 
| 1469 |  |  |  |  |  |  |  | 
| 1470 |  |  |  |  |  |  | # Dies if any element of @bind is not in [colname => value] format | 
| 1471 |  |  |  |  |  |  | # if bindtype is 'columns'. | 
| 1472 |  |  |  |  |  |  | sub _assert_bindval_matches_bindtype { | 
| 1473 |  |  |  |  |  |  | #  my ($self, @bind) = @_; | 
| 1474 | 95 |  |  | 95 |  | 132 | my $self = shift; | 
| 1475 | 95 | 100 |  |  |  | 216 | if ($self->{bindtype} eq 'columns') { | 
| 1476 | 30 |  |  |  |  | 52 | for (@_) { | 
| 1477 | 31 | 100 | 66 |  |  | 155 | if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) { | 
|  |  |  | 66 |  |  |  |  | 
| 1478 | 10 |  |  |  |  | 21 | puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]" | 
| 1479 |  |  |  |  |  |  | } | 
| 1480 |  |  |  |  |  |  | } | 
| 1481 |  |  |  |  |  |  | } | 
| 1482 |  |  |  |  |  |  | } | 
| 1483 |  |  |  |  |  |  |  | 
| 1484 |  |  |  |  |  |  | sub _join_sql_clauses { | 
| 1485 | 1422 |  |  | 1422 |  | 2375 | my ($self, $logic, $clauses_aref, $bind_aref) = @_; | 
| 1486 |  |  |  |  |  |  |  | 
| 1487 | 1422 | 100 |  |  |  | 2662 | if (@$clauses_aref > 1) { | 
|  |  | 50 |  |  |  |  |  | 
| 1488 | 358 |  |  |  |  | 567 | my $join  = " " . $self->_sqlcase($logic) . " "; | 
| 1489 | 358 |  |  |  |  | 926 | my $sql = '( ' . join($join, @$clauses_aref) . ' )'; | 
| 1490 | 358 |  |  |  |  | 1765 | return ($sql, @$bind_aref); | 
| 1491 |  |  |  |  |  |  | } | 
| 1492 |  |  |  |  |  |  | elsif (@$clauses_aref) { | 
| 1493 | 1064 |  |  |  |  | 3196 | return ($clauses_aref->[0], @$bind_aref); # no parentheses | 
| 1494 |  |  |  |  |  |  | } | 
| 1495 |  |  |  |  |  |  | else { | 
| 1496 | 0 |  |  |  |  | 0 | return (); # if no SQL, ignore @$bind_aref | 
| 1497 |  |  |  |  |  |  | } | 
| 1498 |  |  |  |  |  |  | } | 
| 1499 |  |  |  |  |  |  |  | 
| 1500 |  |  |  |  |  |  |  | 
| 1501 |  |  |  |  |  |  | # Fix SQL case, if so requested | 
| 1502 |  |  |  |  |  |  | sub _sqlcase { | 
| 1503 |  |  |  |  |  |  | # LDNOTE: if $self->{case} is true, then it contains 'lower', so we | 
| 1504 |  |  |  |  |  |  | # don't touch the argument ... crooked logic, but let's not change it! | 
| 1505 | 2318 | 100 |  | 2318 |  | 6815 | return $_[0]->{case} ? $_[1] : uc($_[1]); | 
| 1506 |  |  |  |  |  |  | } | 
| 1507 |  |  |  |  |  |  |  | 
| 1508 |  |  |  |  |  |  |  | 
| 1509 |  |  |  |  |  |  | #====================================================================== | 
| 1510 |  |  |  |  |  |  | # DISPATCHING FROM REFKIND | 
| 1511 |  |  |  |  |  |  | #====================================================================== | 
| 1512 |  |  |  |  |  |  |  | 
| 1513 |  |  |  |  |  |  | sub _refkind { | 
| 1514 | 5392 |  |  | 5392 |  | 6561 | my ($self, $data) = @_; | 
| 1515 |  |  |  |  |  |  |  | 
| 1516 | 5392 | 100 |  |  |  | 8405 | return 'UNDEF' unless defined $data; | 
| 1517 |  |  |  |  |  |  |  | 
| 1518 |  |  |  |  |  |  | # blessed objects are treated like scalars | 
| 1519 | 5140 | 100 |  |  |  | 10620 | my $ref = (Scalar::Util::blessed $data) ? '' : ref $data; | 
| 1520 |  |  |  |  |  |  |  | 
| 1521 | 5140 | 100 |  |  |  | 8972 | return 'SCALAR' unless $ref; | 
| 1522 |  |  |  |  |  |  |  | 
| 1523 | 3166 |  |  |  |  | 3711 | my $n_steps = 1; | 
| 1524 | 3166 |  |  |  |  | 5443 | while ($ref eq 'REF') { | 
| 1525 | 108 |  |  |  |  | 159 | $data = $$data; | 
| 1526 | 108 | 100 |  |  |  | 234 | $ref = (Scalar::Util::blessed $data) ? '' : ref $data; | 
| 1527 | 108 | 100 |  |  |  | 245 | $n_steps++ if $ref; | 
| 1528 |  |  |  |  |  |  | } | 
| 1529 |  |  |  |  |  |  |  | 
| 1530 | 3166 |  | 100 |  |  | 9037 | return ($ref||'SCALAR') . ('REF' x $n_steps); | 
| 1531 |  |  |  |  |  |  | } | 
| 1532 |  |  |  |  |  |  |  | 
| 1533 |  |  |  |  |  |  | sub _try_refkind { | 
| 1534 | 5379 |  |  | 5379 |  | 6771 | my ($self, $data) = @_; | 
| 1535 | 5379 |  |  |  |  | 7636 | my @try = ($self->_refkind($data)); | 
| 1536 | 5379 | 100 | 100 |  |  | 13939 | push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF'; | 
| 1537 | 5379 |  |  |  |  | 6464 | push @try, 'FALLBACK'; | 
| 1538 | 5379 |  |  |  |  | 9870 | return \@try; | 
| 1539 |  |  |  |  |  |  | } | 
| 1540 |  |  |  |  |  |  |  | 
| 1541 |  |  |  |  |  |  | sub _METHOD_FOR_refkind { | 
| 1542 | 2663 |  |  | 2663 |  | 3754 | my ($self, $meth_prefix, $data) = @_; | 
| 1543 |  |  |  |  |  |  |  | 
| 1544 | 2663 |  |  |  |  | 2856 | my $method; | 
| 1545 | 2663 |  |  |  |  | 2778 | for (@{$self->_try_refkind($data)}) { | 
|  | 2663 |  |  |  |  | 3670 |  | 
| 1546 | 2663 | 50 |  |  |  | 9494 | $method = $self->can($meth_prefix."_".$_) | 
| 1547 |  |  |  |  |  |  | and last; | 
| 1548 |  |  |  |  |  |  | } | 
| 1549 |  |  |  |  |  |  |  | 
| 1550 | 2663 |  | 33 |  |  | 6718 | return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data); | 
| 1551 |  |  |  |  |  |  | } | 
| 1552 |  |  |  |  |  |  |  | 
| 1553 |  |  |  |  |  |  |  | 
| 1554 |  |  |  |  |  |  | sub _SWITCH_refkind { | 
| 1555 | 2716 |  |  | 2716 |  | 4742 | my ($self, $data, $dispatch_table) = @_; | 
| 1556 |  |  |  |  |  |  |  | 
| 1557 | 2716 |  |  |  |  | 2963 | my $coderef; | 
| 1558 | 2716 |  |  |  |  | 2874 | for (@{$self->_try_refkind($data)}) { | 
|  | 2716 |  |  |  |  | 3887 |  | 
| 1559 | 3526 | 100 |  |  |  | 6738 | $coderef = $dispatch_table->{$_} | 
| 1560 |  |  |  |  |  |  | and last; | 
| 1561 |  |  |  |  |  |  | } | 
| 1562 |  |  |  |  |  |  |  | 
| 1563 | 2716 | 50 |  |  |  | 4961 | puke "no dispatch entry for ".$self->_refkind($data) | 
| 1564 |  |  |  |  |  |  | unless $coderef; | 
| 1565 |  |  |  |  |  |  |  | 
| 1566 | 2716 |  |  |  |  | 3751 | $coderef->(); | 
| 1567 |  |  |  |  |  |  | } | 
| 1568 |  |  |  |  |  |  |  | 
| 1569 |  |  |  |  |  |  |  | 
| 1570 |  |  |  |  |  |  |  | 
| 1571 |  |  |  |  |  |  |  | 
| 1572 |  |  |  |  |  |  | #====================================================================== | 
| 1573 |  |  |  |  |  |  | # VALUES, GENERATE, AUTOLOAD | 
| 1574 |  |  |  |  |  |  | #====================================================================== | 
| 1575 |  |  |  |  |  |  |  | 
| 1576 |  |  |  |  |  |  | # LDNOTE: original code from nwiger, didn't touch code in that section | 
| 1577 |  |  |  |  |  |  | # I feel the AUTOLOAD stuff should not be the default, it should | 
| 1578 |  |  |  |  |  |  | # only be activated on explicit demand by user. | 
| 1579 |  |  |  |  |  |  |  | 
| 1580 |  |  |  |  |  |  | sub values { | 
| 1581 | 6 |  |  | 6 | 1 | 6942 | my $self = shift; | 
| 1582 | 6 |  | 50 |  |  | 14 | my $data = shift || return; | 
| 1583 | 6 | 50 |  |  |  | 15 | puke "Argument to ", __PACKAGE__, "->values must be a \\%hash" | 
| 1584 |  |  |  |  |  |  | unless ref $data eq 'HASH'; | 
| 1585 |  |  |  |  |  |  |  | 
| 1586 | 6 |  |  |  |  | 10 | my @all_bind; | 
| 1587 | 6 |  |  |  |  | 28 | foreach my $k (sort keys %$data) { | 
| 1588 | 37 |  |  |  |  | 49 | my $v = $data->{$k}; | 
| 1589 |  |  |  |  |  |  | $self->_SWITCH_refkind($v, { | 
| 1590 |  |  |  |  |  |  | ARRAYREF => sub { | 
| 1591 | 1 | 50 |  | 1 |  | 3 | if ($self->{array_datatypes}) { # array datatype | 
| 1592 | 0 |  |  |  |  | 0 | push @all_bind, $self->_bindtype($k, $v); | 
| 1593 |  |  |  |  |  |  | } | 
| 1594 |  |  |  |  |  |  | else {                          # literal SQL with bind | 
| 1595 | 1 |  |  |  |  | 2 | my ($sql, @bind) = @$v; | 
| 1596 | 1 |  |  |  |  | 4 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1597 | 1 |  |  |  |  | 6 | push @all_bind, @bind; | 
| 1598 |  |  |  |  |  |  | } | 
| 1599 |  |  |  |  |  |  | }, | 
| 1600 |  |  |  |  |  |  | ARRAYREFREF => sub { # literal SQL with bind | 
| 1601 | 1 |  |  | 1 |  | 2 | my ($sql, @bind) = @${$v}; | 
|  | 1 |  |  |  |  | 2 |  | 
| 1602 | 1 |  |  |  |  | 2 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1603 | 1 |  |  |  |  | 4 | push @all_bind, @bind; | 
| 1604 |  |  |  |  |  |  | }, | 
| 1605 |  |  |  | 2 |  |  | SCALARREF => sub {  # literal SQL without bind | 
| 1606 |  |  |  |  |  |  | }, | 
| 1607 |  |  |  |  |  |  | SCALAR_or_UNDEF => sub { | 
| 1608 | 33 |  |  | 33 |  | 47 | push @all_bind, $self->_bindtype($k, $v); | 
| 1609 |  |  |  |  |  |  | }, | 
| 1610 | 37 |  |  |  |  | 204 | }); | 
| 1611 |  |  |  |  |  |  | } | 
| 1612 |  |  |  |  |  |  |  | 
| 1613 | 6 |  |  |  |  | 67 | return @all_bind; | 
| 1614 |  |  |  |  |  |  | } | 
| 1615 |  |  |  |  |  |  |  | 
| 1616 |  |  |  |  |  |  | sub generate { | 
| 1617 | 0 |  |  | 0 | 1 | 0 | my $self  = shift; | 
| 1618 |  |  |  |  |  |  |  | 
| 1619 | 0 |  |  |  |  | 0 | my(@sql, @sqlq, @sqlv); | 
| 1620 |  |  |  |  |  |  |  | 
| 1621 | 0 |  |  |  |  | 0 | for (@_) { | 
| 1622 | 0 |  |  |  |  | 0 | my $ref = ref $_; | 
| 1623 | 0 | 0 |  |  |  | 0 | if ($ref eq 'HASH') { | 
|  |  | 0 |  |  |  |  |  | 
|  |  | 0 |  |  |  |  |  | 
| 1624 | 0 |  |  |  |  | 0 | for my $k (sort keys %$_) { | 
| 1625 | 0 |  |  |  |  | 0 | my $v = $_->{$k}; | 
| 1626 | 0 |  |  |  |  | 0 | my $r = ref $v; | 
| 1627 | 0 |  |  |  |  | 0 | my $label = $self->_quote($k); | 
| 1628 | 0 | 0 |  |  |  | 0 | if ($r eq 'ARRAY') { | 
|  |  | 0 |  |  |  |  |  | 
| 1629 |  |  |  |  |  |  | # literal SQL with bind | 
| 1630 | 0 |  |  |  |  | 0 | my ($sql, @bind) = @$v; | 
| 1631 | 0 |  |  |  |  | 0 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1632 | 0 |  |  |  |  | 0 | push @sqlq, "$label = $sql"; | 
| 1633 | 0 |  |  |  |  | 0 | push @sqlv, @bind; | 
| 1634 |  |  |  |  |  |  | } elsif ($r eq 'SCALAR') { | 
| 1635 |  |  |  |  |  |  | # literal SQL without bind | 
| 1636 | 0 |  |  |  |  | 0 | push @sqlq, "$label = $$v"; | 
| 1637 |  |  |  |  |  |  | } else { | 
| 1638 | 0 |  |  |  |  | 0 | push @sqlq, "$label = ?"; | 
| 1639 | 0 |  |  |  |  | 0 | push @sqlv, $self->_bindtype($k, $v); | 
| 1640 |  |  |  |  |  |  | } | 
| 1641 |  |  |  |  |  |  | } | 
| 1642 | 0 |  |  |  |  | 0 | push @sql, $self->_sqlcase('set'), join ', ', @sqlq; | 
| 1643 |  |  |  |  |  |  | } elsif ($ref eq 'ARRAY') { | 
| 1644 |  |  |  |  |  |  | # unlike insert(), assume these are ONLY the column names, i.e. for SQL | 
| 1645 | 0 |  |  |  |  | 0 | for my $v (@$_) { | 
| 1646 | 0 |  |  |  |  | 0 | my $r = ref $v; | 
| 1647 | 0 | 0 |  |  |  | 0 | if ($r eq 'ARRAY') {   # literal SQL with bind | 
|  |  | 0 |  |  |  |  |  | 
| 1648 | 0 |  |  |  |  | 0 | my ($sql, @bind) = @$v; | 
| 1649 | 0 |  |  |  |  | 0 | $self->_assert_bindval_matches_bindtype(@bind); | 
| 1650 | 0 |  |  |  |  | 0 | push @sqlq, $sql; | 
| 1651 | 0 |  |  |  |  | 0 | push @sqlv, @bind; | 
| 1652 |  |  |  |  |  |  | } elsif ($r eq 'SCALAR') {  # literal SQL without bind | 
| 1653 |  |  |  |  |  |  | # embedded literal SQL | 
| 1654 | 0 |  |  |  |  | 0 | push @sqlq, $$v; | 
| 1655 |  |  |  |  |  |  | } else { | 
| 1656 | 0 |  |  |  |  | 0 | push @sqlq, '?'; | 
| 1657 | 0 |  |  |  |  | 0 | push @sqlv, $v; | 
| 1658 |  |  |  |  |  |  | } | 
| 1659 |  |  |  |  |  |  | } | 
| 1660 | 0 |  |  |  |  | 0 | push @sql, '(' . join(', ', @sqlq) . ')'; | 
| 1661 |  |  |  |  |  |  | } elsif ($ref eq 'SCALAR') { | 
| 1662 |  |  |  |  |  |  | # literal SQL | 
| 1663 | 0 |  |  |  |  | 0 | push @sql, $$_; | 
| 1664 |  |  |  |  |  |  | } else { | 
| 1665 |  |  |  |  |  |  | # strings get case twiddled | 
| 1666 | 0 |  |  |  |  | 0 | push @sql, $self->_sqlcase($_); | 
| 1667 |  |  |  |  |  |  | } | 
| 1668 |  |  |  |  |  |  | } | 
| 1669 |  |  |  |  |  |  |  | 
| 1670 | 0 |  |  |  |  | 0 | my $sql = join ' ', @sql; | 
| 1671 |  |  |  |  |  |  |  | 
| 1672 |  |  |  |  |  |  | # this is pretty tricky | 
| 1673 |  |  |  |  |  |  | # if ask for an array, return ($stmt, @bind) | 
| 1674 |  |  |  |  |  |  | # otherwise, s/?/shift @sqlv/ to put it inline | 
| 1675 | 0 | 0 |  |  |  | 0 | if (wantarray) { | 
| 1676 | 0 |  |  |  |  | 0 | return ($sql, @sqlv); | 
| 1677 |  |  |  |  |  |  | } else { | 
| 1678 | 0 |  |  |  |  | 0 | 1 while $sql =~ s/\?/my $d = shift(@sqlv); | 
|  | 0 |  |  |  |  | 0 |  | 
| 1679 | 0 | 0 |  |  |  | 0 | ref $d ? $d->[1] : $d/e; | 
| 1680 | 0 |  |  |  |  | 0 | return $sql; | 
| 1681 |  |  |  |  |  |  | } | 
| 1682 |  |  |  |  |  |  | } | 
| 1683 |  |  |  |  |  |  |  | 
| 1684 |  |  |  |  |  |  |  | 
| 1685 | 611 |  |  | 611 |  | 170676 | sub DESTROY { 1 } | 
| 1686 |  |  |  |  |  |  |  | 
| 1687 |  |  |  |  |  |  | sub AUTOLOAD { | 
| 1688 |  |  |  |  |  |  | # This allows us to check for a local, then _form, attr | 
| 1689 | 0 |  |  | 0 |  |  | my $self = shift; | 
| 1690 | 0 |  |  |  |  |  | my($name) = $AUTOLOAD =~ /.*::(.+)/; | 
| 1691 | 0 |  |  |  |  |  | return $self->generate($name, @_); | 
| 1692 |  |  |  |  |  |  | } | 
| 1693 |  |  |  |  |  |  |  | 
| 1694 |  |  |  |  |  |  | 1; | 
| 1695 |  |  |  |  |  |  |  | 
| 1696 |  |  |  |  |  |  |  | 
| 1697 |  |  |  |  |  |  |  | 
| 1698 |  |  |  |  |  |  | __END__ |