← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:16:49 2016
Reported on Fri Jan 8 14:23:08 2016

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