File Coverage

blib/lib/SQL/Abstract/More.pm
Criterion Covered Total %
statement 415 501 82.8
branch 179 238 75.2
condition 48 80 60.0
subroutine 48 65 73.8
pod 13 13 100.0
total 703 897 78.3


line stmt bran cond sub pod time code
1             package SQL::Abstract::More;
2 9     9   452279 use strict;
  9         88  
  9         231  
3 9     9   42 use warnings;
  9         16  
  9         264  
4              
5 9     9   6817 use SQL::Abstract 1.85;
  9         168034  
  9         500  
6 9     9   4346 use parent 'SQL::Abstract'; # THINK : maybe there should be an import option to
  9         2411  
  9         48  
7             # inherit from SQL::Abstract::Classic instead of SQL::Abstract,
8             # so that clients may choose...
9 9     9   4426 use MRO::Compat;
  9         14008  
  9         243  
10 9     9   55 use mro 'c3'; # implements next::method
  9         18  
  9         68  
11              
12 9         751 use Params::Validate qw/validate SCALAR SCALARREF CODEREF ARRAYREF HASHREF
13 9     9   4779 UNDEF BOOLEAN/;
  9         77389  
14 9     9   68 use Scalar::Util qw/blessed reftype/;
  9         16  
  9         620  
15              
16             # import error-reporting functions from SQL::Abstract
17 9     9   35 BEGIN {*puke = \&SQL::Abstract::puke; *belch = \&SQL::Abstract::belch;}
  9         140  
18              
19             # remove all previously defined or imported functions
20 9     9   4009 use namespace::clean;
  9         77408  
  9         65  
21              
22             our $VERSION = '1.35';
23              
24              
25             #----------------------------------------------------------------------
26             # Utility functions -- not methods -- declared _after_
27             # namespace::clean so that they can remain visible by external
28             # modules. In particular, DBIx::DataModel imports these functions.
29             #----------------------------------------------------------------------
30              
31             # shallow_clone(): copies of the top-level keys and values, blessed into the same class
32             sub shallow_clone {
33 5     5 1 15 my ($orig, %override) = @_;
34              
35 5 50       13 my $class = ref $orig
36             or puke "arg must be an object";
37 5         75 my $clone = {%$orig, %override};
38 5         20 return bless $clone, $class;
39             }
40              
41              
42             # does(): cheap version of Scalar::Does
43             my %meth_for = (
44             ARRAY => '@{}',
45             HASH => '%{}',
46             SCALAR => '${}',
47             CODE => '&{}',
48             );
49             sub does ($$) {
50 187     187 1 333 my ($data, $type) = @_;
51 187         442 my $reft = reftype $data;
52             return defined $reft && $reft eq $type
53 187   66     1182 || blessed $data && overload::Method($data, $meth_for{$type});
54             }
55              
56              
57              
58             #----------------------------------------------------------------------
59             # global variables
60             #----------------------------------------------------------------------
61              
62             # builtin methods for "Limit-Offset" dialects
63             my %limit_offset_dialects = (
64             LimitOffset => sub {my ($self, $limit, $offset) = @_;
65             $offset ||= 0;
66             return "LIMIT ? OFFSET ?", $limit, $offset;},
67             LimitXY => sub {my ($self, $limit, $offset) = @_;
68             $offset ||= 0;
69             return "LIMIT ?, ?", $offset, $limit;},
70             LimitYX => sub {my ($self, $limit, $offset) = @_;
71             $offset ||= 0;
72             return "LIMIT ?, ?", $limit, $offset;},
73             RowNum => sub {
74             my ($self, $limit, $offset) = @_;
75             # HACK below borrowed from SQL::Abstract::Limit. Not perfect, though,
76             # because it brings back an additional column. Should borrow from
77             # DBIx::Class::SQLMaker::LimitDialects, which does the proper job ...
78             # but it says : "!!! THIS IS ALSO HORRIFIC !!! /me ashamed"; so
79             # I'll only take it as last resort; still exploring other ways.
80             # See also L : within that ORM an additional layer is
81             # added to take advantage of Oracle scrollable cursors.
82             my $sql = "SELECT * FROM ("
83             . "SELECT subq_A.*, ROWNUM rownum__index FROM (%s) subq_A "
84             . "WHERE ROWNUM <= ?"
85             . ") subq_B WHERE rownum__index >= ?";
86              
87 9     9   5103 no warnings 'uninitialized'; # in case $limit or $offset is undef
  9         57  
  9         31629  
88             # row numbers start at 1
89             return $sql, $offset + $limit, $offset + 1;
90             },
91             );
92              
93             # builtin join operators with associated sprintf syntax
94             my %common_join_syntax = (
95             '<=>' => '%s INNER JOIN %s ON %s',
96             '=>' => '%s LEFT OUTER JOIN %s ON %s',
97             '<=' => '%s RIGHT OUTER JOIN %s ON %s',
98             '==' => '%s NATURAL JOIN %s',
99             '>=<' => '%s FULL OUTER JOIN %s ON %s',
100             );
101             my %right_assoc_join_syntax = %common_join_syntax;
102             s/JOIN %s/JOIN (%s)/ foreach values %right_assoc_join_syntax;
103              
104             # specification of parameters accepted by the new() method
105             my %params_for_new = (
106             table_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
107             column_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
108             limit_offset => {type => SCALAR|CODEREF, default => 'LimitOffset'},
109             join_syntax => {type => HASHREF, default =>
110             \%common_join_syntax},
111             join_assoc_right => {type => BOOLEAN, default => 0},
112             max_members_IN => {type => SCALAR, optional => 1},
113             multicols_sep => {type => SCALAR|SCALARREF, optional => 1},
114             has_multicols_in_SQL => {type => BOOLEAN, optional => 1},
115             sql_dialect => {type => SCALAR, optional => 1},
116             select_implicitly_for=> {type => SCALAR|UNDEF, optional => 1},
117             );
118              
119             # builtin collection of parameters, for various databases
120             my %sql_dialects = (
121             MsAccess => { join_assoc_right => 1,
122             join_syntax => \%right_assoc_join_syntax},
123             BasisJDBC => { column_alias => "%s %s",
124             max_members_IN => 255 },
125             MySQL_old => { limit_offset => "LimitXY" },
126             Oracle => { limit_offset => "RowNum",
127             max_members_IN => 999,
128             table_alias => '%s %s',
129             column_alias => '%s %s',
130             has_multicols_in_SQL => 1, },
131             );
132              
133              
134             # operators for compound queries
135             my @set_operators = qw/union union_all intersect minus except/;
136              
137             # specification of parameters accepted by select, insert, update, delete
138             my %params_for_select = (
139             -columns => {type => SCALAR|ARRAYREF, default => '*'},
140             -from => {type => SCALAR|SCALARREF|ARRAYREF},
141             -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
142             (map {-$_ => {type => ARRAYREF, optional => 1}} @set_operators),
143             -group_by => {type => SCALAR|ARRAYREF, optional => 1},
144             -having => {type => SCALAR|ARRAYREF|HASHREF, optional => 1,
145             depends => '-group_by'},
146             -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
147             -page_size => {type => SCALAR, optional => 1},
148             -page_index => {type => SCALAR, optional => 1,
149             depends => '-page_size'},
150             -limit => {type => SCALAR, optional => 1},
151             -offset => {type => SCALAR, optional => 1,
152             depends => '-limit'},
153             -for => {type => SCALAR|UNDEF, optional => 1},
154             -want_details => {type => BOOLEAN, optional => 1},
155             );
156             my %params_for_insert = (
157             -into => {type => SCALAR},
158             -values => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
159             -select => {type => HASHREF, optional => 1},
160             -columns => {type => ARRAYREF, optional => 1},
161             -returning => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
162             -add_sql => {type => SCALAR, optional => 1},
163             );
164             my %params_for_update = (
165             -table => {type => SCALAR|SCALARREF|ARRAYREF},
166             -set => {type => HASHREF},
167             -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
168             -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
169             -limit => {type => SCALAR, optional => 1},
170             -returning => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
171             -add_sql => {type => SCALAR, optional => 1},
172             );
173             my %params_for_delete = (
174             -from => {type => SCALAR},
175             -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
176             -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
177             -limit => {type => SCALAR, optional => 1},
178             -add_sql => {type => SCALAR, optional => 1},
179             );
180             my %params_for_WITH = (
181             -table => {type => SCALAR},
182             -columns => {type => SCALAR|ARRAYREF, optional => 1},
183             -as_select => {type => HASHREF},
184             -final_clause => {type => SCALAR, optional => 1},
185             );
186              
187              
188              
189             #----------------------------------------------------------------------
190             # object creation
191             #----------------------------------------------------------------------
192              
193             sub new {
194 18     18 1 33864 my $class = shift;
195 18 100       72 my %params = does($_[0], 'HASH') ? %{$_[0]} : @_;
  1         5  
196              
197             # extract params for this subclass
198 18         43 my %more_params;
199 18         94 foreach my $key (keys %params_for_new) {
200 180 100       307 $more_params{$key} = delete $params{$key} if exists $params{$key};
201             }
202              
203             # import params from SQL dialect, if any
204 18         46 my $dialect = delete $more_params{sql_dialect};
205 18 100       49 if ($dialect) {
206 2 50       9 my $dialect_params = $sql_dialects{$dialect}
207             or puke "no such sql dialect: $dialect";
208 2   33     25 $more_params{$_} ||= $dialect_params->{$_} foreach keys %$dialect_params;
209             }
210              
211             # check parameters for this class
212 18         45 my @more_params = %more_params;
213 18         507 my $more_self = validate(@more_params, \%params_for_new);
214              
215             # check some of the params for parent -- because SQLA doesn't do it :-(
216             !$params{quote_char} || exists $params{name_sep}
217 18 50 66     105 or belch "when 'quote_char' is present, 'name_sep' should be present too";
218              
219             # call parent constructor
220 18         100 my $self = $class->next::method(%params);
221              
222             # inject into $self
223 18         4721 $self->{$_} = $more_self->{$_} foreach keys %$more_self;
224              
225             # arguments supplied as scalars are transformed into coderefs
226 18 50       124 ref $self->{column_alias} or $self->_make_sub_column_alias;
227 18 50       84 ref $self->{table_alias} or $self->_make_sub_table_alias;
228 18 100       94 ref $self->{limit_offset} or $self->_choose_LIMIT_OFFSET_dialect;
229              
230             # regex for parsing join specifications
231 142 50       321 my @join_ops = sort {length($b) <=> length($a) || $a cmp $b}
232 18         33 keys %{$self->{join_syntax}};
  18         124  
233 18         134 my $joined_ops = join '|', map quotemeta, @join_ops;
234 18         574 $self->{join_regex} = qr[
235             ^ # initial anchor
236             ($joined_ops)? # $1: join operator (i.e. '<=>', '=>', etc.))
237             ([[{])? # $2: opening '[' or '{'
238             (.*?) # $3: content of brackets
239             []}]? # closing ']' or '}'
240             $ # final anchor
241             ]x;
242              
243 18         161 return $self;
244             }
245              
246              
247              
248             #----------------------------------------------------------------------
249             # support for WITH or WITH RECURSIVE
250             #----------------------------------------------------------------------
251              
252             sub with_recursive {
253 5     5 1 37291 my $self = shift;
254              
255 5         15 my $new_instance = $self->with(@_);
256 5         20 $new_instance->{WITH}{sql} =~ s/^WITH\b/WITH RECURSIVE/;
257              
258 5         23 return $new_instance;
259             }
260              
261             sub with {
262 5     5 1 8 my $self = shift;
263              
264             ! $self->{WITH}
265 5 50       14 or puke "calls to the with() or with_recursive() method cannot be chained";
266              
267             @_
268 5 50       12 or puke "->with() : missing arguments";
269              
270             # create a copy of the current object with an additional attribute WITH
271 5         19 my $clone = shallow_clone($self, WITH => {sql => "", bind => []});
272              
273             # assemble SQL and bind values for each table expression
274 5 100       14 my @table_expressions = does($_[0], 'ARRAY') ? @_ : ( [ @_]);
275 5         10 foreach my $table_expression (@table_expressions) {
276 6         141 my %args = validate(@$table_expression, \%params_for_WITH);
277 6         27 my ($sql, @bind) = $self->select(%{$args{-as_select}});
  6         31  
278 6 100       16 $clone->{WITH}{sql} .= ", " if $clone->{WITH}{sql};
279 6         14 $clone->{WITH}{sql} .= $args{-table};
280 6 50       13 $clone->{WITH}{sql} .= "(" . join(", ", @{$args{-columns}}) . ")" if $args{-columns};
  6         14  
281 6         14 $clone->{WITH}{sql} .= " AS ($sql) ";
282 6 100       14 $clone->{WITH}{sql} .= $args{-final_clause} . " " if $args{-final_clause};
283 6         7 push @{$clone->{WITH}{bind}}, @bind;
  6         18  
284             }
285              
286             # add the initial keyword WITH
287 5         10 substr($clone->{WITH}{sql}, 0, 0, 'WITH ');
288              
289 5         10 return $clone;
290             }
291              
292              
293             sub _prepend_WITH_clause {
294 83     83   135 my ($self, $ref_sql, $ref_bind) = @_;
295              
296 83 100       177 return if !$self->{WITH};
297              
298 9         28 substr($$ref_sql, 0, 0, $self->{WITH}{sql});
299 9         12 unshift @$ref_bind, @{$self->{WITH}{bind}};
  9         17  
300              
301             }
302              
303              
304             #----------------------------------------------------------------------
305             # the select method
306             #----------------------------------------------------------------------
307              
308             sub select {
309 59     59 1 116354 my $self = shift;
310              
311             # if got positional args, this is not our job, just delegate to the parent
312 59 100       128 return $self->next::method(@_) if !&_called_with_named_args;
313              
314 58         97 my %aliased_columns;
315              
316             # parse arguments
317 58         1719 my %args = validate(@_, \%params_for_select);
318              
319             # compute join info if the datasource is a join
320 58         346 my $join_info = $self->_compute_join_info($args{-from});
321 58 100       121 $args{-from} = \($join_info->{sql}) if $join_info;
322              
323             # reorganize columns; initial members starting with "-" are extracted
324             # into a separate list @post_select, later re-injected into the SQL
325 58 100       153 my @cols = ref $args{-columns} ? @{$args{-columns}} : $args{-columns};
  33         74  
326 58         83 my @post_select;
327 58   66     277 push @post_select, shift @cols while @cols && $cols[0] =~ s/^-//;
328 58         102 foreach my $col (@cols) {
329             # extract alias, if any
330 82 100       250 if ($col =~ /^\s* # ignore insignificant leading spaces
331             (.*[^|\s]) # any non-empty string, not ending with ' ' or '|'
332             \| # followed by a literal '|'
333             (\w+) # followed by a word (the alias))
334             \s* # ignore insignificant trailing spaces
335             $/x) {
336 14         60 $aliased_columns{$2} = $1;
337 14         30 $col = $self->column_alias($1, $2);
338             }
339             }
340 58         102 $args{-columns} = \@cols;
341              
342             # reorganize pagination
343 58 100 66     252 if ($args{-page_index} || $args{-page_size}) {
344             not exists $args{$_} or puke "-page_size conflicts with $_"
345 1   33     7 for qw/-limit -offset/;
346 1         3 $args{-limit} = $args{-page_size};
347 1 50       3 if ($args{-page_index}) {
348 1         5 $args{-offset} = ($args{-page_index} - 1) * $args{-page_size};
349             }
350             }
351              
352             # generate initial ($sql, @bind), without -order_by (will be handled later)
353 58         146 my @old_API_args = @args{qw/-from -columns -where/}; #
354 58         175 my ($sql, @bind) = $self->next::method(@old_API_args);
355 58 100       46490 unshift @bind, @{$join_info->{bind}} if $join_info;
  11         26  
356              
357             # add @post_select clauses if needed (for ex. -distinct)
358 58         110 my $post_select = join " ", @post_select;
359 58 100       140 $sql =~ s[^SELECT ][SELECT $post_select ]i if $post_select;
360              
361             # add set operators (UNION, INTERSECT, etc) if needed
362 58         123 foreach my $set_op (@set_operators) {
363 290 100       554 if ($args{-$set_op}) {
364 11         18 my %sub_args = @{$args{-$set_op}};
  11         36  
365 11   66     53 $sub_args{$_} ||= $args{$_} for qw/-columns -from/;
366 11         33 local $self->{WITH}; # temporarily enable the WITH part during the subquery
367 11         95 my ($sql1, @bind1) = $self->select(%sub_args);
368 11         45 (my $sql_op = uc($set_op)) =~ s/_/ /g;
369 11         34 $sql .= " $sql_op $sql1";
370 11         29 push @bind, @bind1;
371             }
372             }
373              
374             # add GROUP BY/HAVING if needed
375 58 100       116 if ($args{-group_by}) {
376 4         21 my $sql_grp = $self->where(undef, $args{-group_by});
377 4         952 $sql_grp =~ s/\bORDER\b/GROUP/;
378 4 100       17 if ($args{-having}) {
379 2         8 my ($sql_having, @bind_having) = $self->where($args{-having});
380 2         742 $sql_having =~ s/\bWHERE\b/HAVING/;
381 2         6 $sql_grp .= " $sql_having";
382 2         6 push @bind, @bind_having;
383             }
384 4         12 $sql .= $sql_grp;
385             }
386              
387             # add ORDER BY if needed
388 58 100       122 if (my $order = $args{-order_by}) {
389              
390 7         31 my ($sql_order, @orderby_bind) = $self->_order_by($order);
391 7         2254 $sql .= $sql_order;
392 7         15 push @bind, @orderby_bind;
393             }
394              
395             # add LIMIT/OFFSET if needed
396 58 100       117 if (defined $args{-limit}) {
397             my ($limit_sql, @limit_bind)
398 5         14 = $self->limit_offset(@args{qw/-limit -offset/});
399 5 100       21 $sql = $limit_sql =~ /%s/ ? sprintf $limit_sql, $sql
400             : "$sql $limit_sql";
401 5         11 push @bind, @limit_bind;
402             }
403              
404             # add FOR clause if needed
405 58 100       135 my $for = exists $args{-for} ? $args{-for} : $self->{select_implicitly_for};
406 58 100       111 $sql .= " FOR $for" if $for;
407              
408             # initial WITH clause
409 58         154 $self->_prepend_WITH_clause(\$sql, \@bind);
410              
411             # return results
412 58 100       121 if ($args{-want_details}) {
413             return {sql => $sql,
414             bind => \@bind,
415 1   33     11 aliased_tables => ($join_info && $join_info->{aliased_tables}),
416             aliased_columns => \%aliased_columns };
417             }
418             else {
419 57         313 return ($sql, @bind);
420             }
421             }
422              
423             #----------------------------------------------------------------------
424             # insert, update and delete methods
425             #----------------------------------------------------------------------
426              
427             sub insert {
428 11     11 1 24694 my $self = shift;
429              
430 11         36 my @old_API_args;
431             my $returning_into;
432 11         0 my $sql_to_add;
433 11         0 my $fix_RT134127;
434              
435 11 100       25 if (&_called_with_named_args) {
436             # extract named args and translate to old SQLA API
437 10         439 my %args = validate(@_, \%params_for_insert);
438             $old_API_args[0] = $args{-into}
439 9 50       51 or puke "insert(..) : need -into arg";
440              
441 9 100       26 if ($args{-values}) {
    50          
442              
443             # check mutually exclusive parameters
444             !$args{$_}
445             or puke "insert(-into => .., -values => ...) : cannot use $_ => "
446 7   33     28 for qw/-select -columns/;
447              
448 7         10 $old_API_args[1] = $args{-values};
449             }
450             elsif ($args{-select}) {
451 2         6 local $self->{WITH}; # temporarily enable the WITH part during the subquery
452 2         4 my ($sql, @bind) = $self->select(%{$args{-select}});
  2         9  
453 2         7 $old_API_args[1] = \ [$sql, @bind];
454 2 50       9 if (my $cols = $args{-columns}) {
455 2         9 $old_API_args[0] .= "(" . CORE::join(", ", @$cols) . ")";
456             }
457 2 50       14 $fix_RT134127 = 1 if $SQL::Abstract::VERSION >= 2.0;
458             }
459             else {
460 0         0 puke "insert(-into => ..) : need either -values arg or -select arg";
461             }
462              
463             # deal with -returning arg
464             ($returning_into, my $old_API_options)
465 9         28 = $self->_compute_returning($args{-returning});
466 9 100       21 push @old_API_args, $old_API_options if $old_API_options;
467              
468             # SQL to add after the INSERT keyword
469 9         23 $sql_to_add = $args{-add_sql};
470             }
471             else {
472 1         3 @old_API_args = @_;
473             }
474              
475             # get results from parent method
476 10         35 my ($sql, @bind) = $self->next::method(@old_API_args);
477              
478             # temporary fix for RT#134127 due to a change of behaviour of insert() in SQLA V2.0
479             # .. waiting for SQLA to fix RT#134128
480 10 100       9660 $sql =~ s/VALUES SELECT/SELECT/ if $fix_RT134127;
481              
482             # inject more stuff if using Oracle's "RETURNING ... INTO ..."
483 10 100       22 if ($returning_into) {
484 1         8 $sql .= ' INTO ' . join(", ", ("?") x @$returning_into);
485 1         3 push @bind, @$returning_into;
486             }
487              
488             # SQL to add after the INSERT keyword
489 10 100       32 $sql =~ s/\b(INSERT)\b/$1 $sql_to_add/i if $sql_to_add;
490              
491             # initial WITH clause
492 10         31 $self->_prepend_WITH_clause(\$sql, \@bind);
493              
494 10         49 return ($sql, @bind);
495             }
496              
497              
498             sub update {
499 10     10 1 30579 my $self = shift;
500              
501 10         33 my $join_info;
502             my @old_API_args;
503 10         0 my $returning_into;
504 10         0 my %args;
505 10 100       19 if (&_called_with_named_args) {
506 9         208 %args = validate(@_, \%params_for_update);
507              
508             # compute join info if the datasource is a join
509 9         50 $join_info = $self->_compute_join_info($args{-table});
510 9 100       19 $args{-table} = \($join_info->{sql}) if $join_info;
511              
512 9         21 @old_API_args = @args{qw/-table -set -where/};
513              
514             # deal with -returning arg
515             ($returning_into, my $old_API_options)
516 9         27 = $self->_compute_returning($args{-returning});
517 9 100       25 push @old_API_args, $old_API_options if $old_API_options;
518             }
519             else {
520 1         4 @old_API_args = @_;
521             }
522              
523             # call parent method and merge with bind values from $join_info
524 10         33 my ($sql, @bind) = $self->next::method(@old_API_args);
525 10 100       13234 unshift @bind, @{$join_info->{bind}} if $join_info;
  1         5  
526              
527             # handle additional args if needed
528 10         49 $self->_handle_additional_args_for_update_delete(\%args, \$sql, \@bind, qr/UPDATE/);
529              
530             # inject more stuff if using Oracle's "RETURNING ... INTO ..."
531 10 100       29 if ($returning_into) {
532 1         5 $sql .= ' INTO ' . join(", ", ("?") x @$returning_into);
533 1         2 push @bind, @$returning_into;
534             }
535              
536             # initial WITH clause
537 10         27 $self->_prepend_WITH_clause(\$sql, \@bind);
538              
539 10         69 return ($sql, @bind);
540             }
541              
542              
543             sub _compute_returning {
544 18     18   38 my ($self, $arg_returning) = @_;
545              
546 18         29 my ($returning_into, $old_API_options);
547              
548 18 100       33 if ($arg_returning) {
549             # if present, "-returning" may be a scalar, arrayref or hashref; the latter
550             # is interpreted as .. RETURNING ... INTO ...
551              
552              
553 6 100       14 if (does $arg_returning, 'HASH') {
554 2 50       13 my @keys = sort keys %$arg_returning
555             or puke "-returning => {} : the hash is empty";
556              
557 2         9 $old_API_options = {returning => \@keys};
558 2         4 $returning_into = [@{$arg_returning}{@keys}];
  2         6  
559             }
560             else {
561 4         11 $old_API_options = {returning => $arg_returning};
562             }
563             }
564              
565 18         34 return ($returning_into, $old_API_options);
566             }
567              
568              
569             sub _handle_additional_args_for_update_delete {
570 15     15   34 my ($self, $args, $sql_ref, $bind_ref, $keyword_regex) = @_;
571              
572 15 100       32 if (defined $args->{-order_by}) {
573 2         7 my ($sql_ob, @bind_ob) = $self->_order_by($args->{-order_by});
574 2         411 $$sql_ref .= $sql_ob;
575 2         5 push @$bind_ref, @bind_ob;
576             }
577 15 100       52 if (defined $args->{-limit}) {
578             # can't call $self->limit_offset(..) because there shouldn't be any offset
579 2         16 $$sql_ref .= $self->_sqlcase(' limit ?');
580 2         12 push @$bind_ref, $args->{-limit};
581             }
582 15 100       33 if (defined $args->{-add_sql}) {
583 2         57 $$sql_ref =~ s/\b($keyword_regex)\b/$1 $args->{-add_sql}/i;
584             }
585             }
586              
587             sub _order_by {
588 54     54   97339 my ($self, $order) = @_;
589              
590             # force scalar into an arrayref
591 54 100       152 $order = [$order] if not ref $order;
592              
593             # restructure array data
594 54 100       119 if (does $order, 'ARRAY') {
595 42         100 my @clone = @$order; # because we will modify items
596              
597             # '-' and '+' prefixes are translated into {-desc/asc => } hashrefs
598 42         71 foreach my $item (@clone) {
599 69 100 100     204 next if !$item or ref $item;
600 35 100 100     115 $item =~ s/^-// and $item = {-desc => $item} and next;
601 32 100       76 $item =~ s/^\+// and $item = {-asc => $item};
602             }
603 42         78 $order = \@clone;
604             }
605              
606 54         179 return $self->next::method($order);
607             }
608              
609             sub delete {
610 5     5 1 14995 my $self = shift;
611              
612 5         12 my @old_API_args;
613             my %args;
614 5 100       13 if (&_called_with_named_args) {
615 4         91 %args = validate(@_, \%params_for_delete);
616 4         21 @old_API_args = @args{qw/-from -where/};
617             }
618             else {
619 1         3 @old_API_args = @_;
620             }
621              
622             # call parent method
623 5         18 my ($sql, @bind) = $self->next::method(@old_API_args);
624              
625             # maybe need to handle additional args
626 5         3711 $self->_handle_additional_args_for_update_delete(\%args, \$sql, \@bind, qr/DELETE/);
627              
628             # initial WITH clause
629 5         22 $self->_prepend_WITH_clause(\$sql, \@bind);
630              
631 5         27 return ($sql, @bind);
632             }
633              
634             #----------------------------------------------------------------------
635             # other public methods
636             #----------------------------------------------------------------------
637              
638             # same pattern for 3 invocation methods
639             foreach my $attr (qw/table_alias column_alias limit_offset/) {
640 9     9   83 no strict 'refs';
  9         19  
  9         888  
641             *{$attr} = sub {
642 89     89   10619 my $self = shift;
643 89         153 my $method = $self->{$attr}; # grab reference to method body
644 89         192 $self->$method(@_); # invoke
645             };
646             }
647              
648             # readonly accessor methods
649             foreach my $key (qw/join_syntax join_assoc_right
650             max_members_IN multicols_sep has_multicols_in_SQL/) {
651 9     9   64 no strict 'refs';
  9         17  
  9         12532  
652 1     1   1650 *{$key} = sub {shift->{$key}};
653             }
654              
655              
656             # invocation method for 'join'
657             sub join {
658 30     30 1 51789 my $self = shift;
659              
660             # start from the right if right-associative
661 30 100       89 @_ = reverse @_ if $self->{join_assoc_right};
662              
663             # shift first single item (a table) before reducing pairs (op, table)
664 30         52 my $combined = shift;
665 30 50       105 $combined = $self->_parse_table($combined) unless ref $combined;
666              
667             # reduce pairs (op, table)
668 30         78 while (@_) {
669             # shift 2 items : next join specification and next table
670 34         59 my $join_spec = shift;
671 34 50       65 my $table_spec = shift or puke "improper number of operands";
672              
673 34 100       104 $join_spec = $self->_parse_join_spec($join_spec) unless ref $join_spec;
674 34 50       107 $table_spec = $self->_parse_table($table_spec) unless ref $table_spec;
675 34         96 $combined = $self->_single_join($combined, $join_spec, $table_spec);
676             }
677              
678 29         79 return $combined; # {sql=> .., bind => [..], aliased_tables => {..}}
679             }
680              
681              
682             # utility for merging several "where" clauses
683             sub merge_conditions {
684 1     1 1 2967 my $self = shift;
685 1         2 my %merged;
686              
687 1         3 foreach my $cond (@_) {
688 2 50       6 if (does $cond, 'HASH') {
    0          
    0          
689 2         7 foreach my $col (sort keys %$cond) {
690             $merged{$col} = $merged{$col} ? [-and => $merged{$col}, $cond->{$col}]
691 4 100       14 : $cond->{$col};
692             }
693             }
694             elsif (does $cond, 'ARRAY') {
695 0 0       0 $merged{-nest} = $merged{-nest} ? {-and => [$merged{-nest}, $cond]}
696             : $cond;
697             }
698             elsif ($cond) {
699 0         0 $merged{$cond} = \"";
700             }
701             }
702 1         3 return \%merged;
703             }
704              
705             # utility for calling either bind_param or bind_param_inout
706             our $INOUT_MAX_LEN = 99; # chosen arbitrarily; see L
707             sub bind_params {
708 0     0 1 0 my ($self, $sth, @bind) = @_;
709 0 0       0 $sth->isa('DBI::st') or puke "sth argument is not a DBI statement handle";
710 0         0 foreach my $i (0 .. $#bind) {
711 0         0 my $val = $bind[$i];
712 0 0 0     0 if (does $val, 'SCALAR') {
    0          
713             # a scalarref is interpreted as an INOUT parameter
714 0         0 $sth->bind_param_inout($i+1, $val, $INOUT_MAX_LEN);
715             }
716             elsif (does $val, 'ARRAY' and
717             my ($bind_meth, @args) = $self->is_bind_value_with_type($val)) {
718             # either 'bind_param' or 'bind_param_inout', with 2 or 3 args
719 0         0 $sth->$bind_meth($i+1, @args);
720             }
721             else {
722             # other cases are passed directly to DBI::bind_param
723 0         0 $sth->bind_param($i+1, $val);
724             }
725             }
726             }
727              
728             sub is_bind_value_with_type {
729 5     5 1 1783 my ($self, $val) = @_;
730              
731             # compatibility with DBIx::Class syntax of shape [\%args => $val],
732             # see L
733 5 100 66     22 if ( @$val == 2
      100        
734             && does($val->[0], 'HASH')
735 12         23 && grep {$val->[0]{$_}} qw/dbd_attrs sqlt_size
736             sqlt_datatype dbic_colname/) {
737 2         4 my $args = $val->[0];
738 2 50       6 if (my $attrs = $args->{dbd_attrs}) {
    0          
739 2         6 return (bind_param => $val->[1], $attrs);
740             }
741             elsif (my $size = $args->{sqlt_size}) {
742 0         0 return (bind_param_inout => $val, $size);
743             }
744             # other options like 'sqlt_datatype', 'dbic_colname' are not supported
745             else {
746 0         0 puke "unsupported options for bind type : "
747             . CORE::join(", ", sort keys %$args);
748             }
749              
750             # NOTE : the following DBIx::Class shortcuts are not supported
751             # [ $name => $val ] === [ { dbic_colname => $name }, $val ]
752             # [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ]
753             # [ undef, $val ] === [ {}, $val ]
754             }
755              
756             # in all other cases, this is not a bind value with type
757 3         9 return ();
758             }
759              
760             #----------------------------------------------------------------------
761             # private utility methods for 'join'
762             #----------------------------------------------------------------------
763              
764             sub _compute_join_info {
765 67     67   134 my ($self, $table_arg) = @_;
766              
767 67 100 66     125 if (does($table_arg, 'ARRAY') && $table_arg->[0] eq '-join') {
768 12         37 my @join_args = @$table_arg;
769 12         19 shift @join_args; # drop initial '-join'
770 12         41 return $self->join(@join_args);
771             }
772             else {
773 55         107 return;
774             }
775             }
776              
777             sub _parse_table {
778 64     64   124 my ($self, $table) = @_;
779              
780             # extract alias, if any (recognized as "table|alias")
781 64         157 ($table, my $alias) = split /\|/, $table, 2;
782              
783             # build a table spec
784             return {
785 64 100 66     160 sql => $self->table_alias($table, $alias),
786             bind => [],
787             name => ($alias || $table),
788             aliased_tables => {$alias ? ($alias => $table) : ()},
789             };
790             }
791              
792             sub _parse_join_spec {
793 31     31   57 my ($self, $join_spec) = @_;
794              
795             # parse the join specification
796 31 50       67 $join_spec
797             or puke "empty join specification";
798             my ($op, $bracket, $cond_list) = ($join_spec =~ $self->{join_regex})
799 31 50       338 or puke "incorrect join specification : $join_spec\n$self->{join_regex}";
800 31   100     134 $op ||= '<=>';
801 31   100     81 $bracket ||= '{';
802 31   100     71 $cond_list ||= '';
803              
804             # extract constants (strings between quotes), replaced by placeholders
805 31         111 my $regex = qr/' # initial quote
806             ( # begin capturing group
807             [^']* # any non-quote chars
808             (?: # begin non-capturing group
809             '' # pair of quotes
810             [^']* # any non-quote chars
811             )* # this non-capturing group 0 or more times
812             ) # end of capturing group
813             ' # ending quote
814             /x;
815 31         65 my $placeholder = '_?_'; # unlikely to be counfounded with any value
816 31         94 my @constants;
817 31         191 while ($cond_list =~ s/$regex/$placeholder/) {
818 6         41 push @constants, $1;
819             };
820 31         83 s/''/'/g for @constants; # replace pairs of quotes by single quotes
821              
822             # accumulate conditions as pairs ($left => \"$op $right")
823 31         55 my @conditions;
824             my @using;
825 31         99 foreach my $cond (split /,\s*/, $cond_list) {
826             # parse the condition (left and right operands + comparison operator)
827 41         147 my ($left, $cmp, $right) = split /([<>=!^]{1,2})/, $cond;
828 41 100 66     149 if ($cmp && $right) {
    50          
829             # if operands are not qualified by table/alias name, add sprintf hooks
830 34 100       95 $left = '%1$s.' . $left unless $left =~ /\./;
831 34 100 100     126 $right = '%2$s.' . $right unless $right =~ /\./ or $right eq $placeholder;
832              
833             # add this pair into the list; right operand is either a bind value
834             # or an identifier within the right table
835 34 100       85 $right = $right eq $placeholder ? shift @constants : {-ident => $right};
836 34         102 push @conditions, $left, {$cmp => $right};
837             }
838             elsif ($cond =~ /^\w+$/) {
839 7         16 push @using, $cond;
840             }
841 0         0 else {puke "can't parse join condition: $cond"}
842             }
843              
844             # build join hashref
845 31         76 my $join_hash = {operator => $op};
846 31 100       75 $join_hash->{using} = \@using if @using;
847             $join_hash->{condition}
848 31 100       116 = $bracket eq '[' ? [@conditions] : {@conditions} if @conditions;
    100          
849              
850 31         108 return $join_hash;
851             }
852              
853             sub _single_join {
854 34     34   61 my $self = shift;
855              
856             # if right-associative, restore proper left-right order in pair
857 34 100       95 @_ = reverse @_ if $self->{join_assoc_right};
858 34         100 my ($left, $join_spec, $right) = @_;
859              
860             # syntax for assembling all elements
861 34         83 my $syntax = $self->{join_syntax}{$join_spec->{operator}};
862              
863 34         46 my ($sql, @bind);
864              
865 9     9   5857 { no if $] ge '5.022000', warnings => 'redundant';
  9         170  
  9         47  
  34         52  
866             # because sprintf instructions may _intentionally_ omit %.. parameters
867              
868 34 100       97 if ($join_spec->{using}) {
    100          
869             not $join_spec->{condition}
870 8 100       21 or puke "join specification has both {condition} and {using} fields";
871              
872 7         41 $syntax =~ s/\bON\s+%s/USING (%s)/;
873 7         11 $sql = CORE::join ",", @{$join_spec->{using}};
  7         32  
874             }
875             elsif ($join_spec->{condition}) {
876             not $join_spec->{using}
877 25 50       56 or puke "join specification has both {condition} and {using} fields";
878              
879             # compute the "ON" clause
880 25         113 ($sql, @bind) = $self->where($join_spec->{condition});
881 25         16001 $sql =~ s/^\s*WHERE\s+//;
882              
883             # substitute left/right tables names for '%1$s', '%2$s'
884 25         116 $sql = sprintf $sql, $left->{name}, $right->{name};
885             }
886              
887             # build the final sql
888 33         130 $sql = sprintf $syntax, $left->{sql}, $right->{sql}, $sql;
889             }
890              
891             # add left/right bind parameters (if any) into the list
892 33         51 unshift @bind, @{$left->{bind}}, @{$right->{bind}};
  33         53  
  33         50  
893              
894             # build result and return
895 33         98 my %result = (sql => $sql, bind => \@bind);
896 33 100       103 $result{name} = ($self->{join_assoc_right} ? $left : $right)->{name};
897 33         51 $result{aliased_tables} = $left->{aliased_tables};
898 33         44 foreach my $alias (keys %{$right->{aliased_tables}}) {
  33         91  
899 6         16 $result{aliased_tables}{$alias} = $right->{aliased_tables}{$alias};
900             }
901              
902 33         206 return \%result;
903             }
904              
905              
906             #----------------------------------------------------------------------
907             # override of parent's "_where_field_IN"
908             #----------------------------------------------------------------------
909              
910             sub _where_field_IN {
911 31     31   59491 my ($self, $k, $op, $vals) = @_;
912              
913             # special algorithm if the key is multi-columns (contains a multicols_sep)
914 31 100       129 if ($self->{multicols_sep}) {
915 8         43 my @cols = split m[$self->{multicols_sep}], $k;
916 8 50       21 if (@cols > 1) {
917 8 100       18 if ($self->{has_multicols_in_SQL}) {
918             # DBMS accepts special SQL syntax for multicolumns
919 6         17 return $self->_multicols_IN_through_SQL(\@cols, $op, $vals);
920             }
921             else {
922             # DBMS doesn't accept special syntax, so we must use boolean logic
923 2         6 return $self->_multicols_IN_through_boolean(\@cols, $op, $vals);
924             }
925             }
926             }
927              
928             # special algorithm if the number of values exceeds the allowed maximum
929 23         38 my $max_members_IN = $self->{max_members_IN};
930 23 100 100     64 if ($max_members_IN && does($vals, 'ARRAY')
      100        
931             && @$vals > $max_members_IN) {
932 4         9 my @vals = @$vals;
933 4         6 my @slices;
934 4         15 while (my @slice = splice(@vals, 0, $max_members_IN)) {
935 12         31 push @slices, \@slice;
936             }
937 4         8 my @clauses = map {{-$op, $_}} @slices;
  12         24  
938 4 100       15 my $connector = $op =~ /^not/i ? '-and' : '-or';
939 4         9 unshift @clauses, $connector;
940 4         16 my ($sql, @bind) = $self->where({$k => \@clauses});
941 4         2753 $sql =~ s/\s*where\s*\((.*)\)/$1/i;
942 4         55 return ($sql, @bind);
943             }
944              
945              
946             # otherwise, call parent method
947 19 100       70 $vals = [@$vals] if blessed $vals; # because SQLA dies on blessed arrayrefs
948 19         61 return $self->next::method($k, $op, $vals);
949             }
950              
951              
952             sub _multicols_IN_through_SQL {
953 6     6   12 my ($self, $cols, $op, $vals) = @_;
954              
955             # build initial sql
956 6         10 my $n_cols = @$cols;
957 6         9 my $sql_cols = CORE::join(',', map {$self->_quote($_)} @$cols);
  14         143  
958 6         89 my $sql = "($sql_cols) " . $self->_sqlcase($op);
959              
960             # dispatch according to structure of $vals
961             return $self->_SWITCH_refkind($vals, {
962              
963             ARRAYREF => sub { # list of tuples
964             # deal with special case of empty list (like the parent class)
965 4     4   132 my $n_tuples = @$vals;
966 4 50       10 if (!$n_tuples) {
967 0 0       0 my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
968 0         0 return ($sql);
969             }
970              
971             # otherwise, build SQL and bind values for the list of tuples
972 4         5 my @bind;
973 4         8 foreach my $val (@$vals) {
974 6 100       11 does($val, 'ARRAY')
975             or $val = [split m[$self->{multicols_sep}], $val];
976 6 50       15 @$val == $n_cols
977             or puke "op '$op' with multicols: tuple with improper number of cols";
978 6         12 push @bind, @$val;
979             }
980 4         22 my $single_tuple = "(" . CORE::join(',', (('?') x $n_cols)) . ")";
981              
982 4         10 my $all_tuples = CORE::join(', ', (($single_tuple) x $n_tuples));
983 4         10 $sql .= " ($all_tuples)";
984 4         87 return ($sql, @bind);
985             },
986              
987             SCALARREF => sub { # literal SQL
988 1     1   29 $sql .= " ($$vals)";
989 1         17 return ($sql);
990             },
991              
992             ARRAYREFREF => sub { # literal SQL with bind
993 1     1   37 my ($inner_sql, @bind) = @$$vals;
994 1         3 $sql .= " ($inner_sql)";
995 1         19 return ($sql, @bind);
996             },
997              
998             FALLBACK => sub {
999 0     0   0 puke "op '$op' with multicols requires a list of tuples or literal SQL";
1000             },
1001              
1002 6         96 });
1003             }
1004              
1005              
1006             sub _multicols_IN_through_boolean {
1007 2     2   6 my ($self, $cols, $op, $vals) = @_;
1008              
1009             # can't handle anything else than a list of tuples
1010 2 50 33     5 does($vals, 'ARRAY') && @$vals
1011             or puke "op '$op' with multicols requires a non-empty list of tuples";
1012              
1013             # assemble SQL
1014 2         4 my $n_cols = @$cols;
1015 2         4 my $sql_cols = CORE::join(' AND ', map {$self->_quote($_) . " = ?"} @$cols);
  5         47  
1016 2         32 my $sql = "(" . CORE::join(' OR ', (("($sql_cols)") x @$vals)) . ")";
1017 2 100       9 $sql = "NOT $sql" if $op =~ /\bnot\b/i;
1018              
1019             # assemble bind values
1020 2         4 my @bind;
1021 2         4 foreach my $val (@$vals) {
1022 3 50       5 does($val, 'ARRAY')
1023             or $val = [split m[$self->{multicols_sep}], $val];
1024 3 50       10 @$val == $n_cols
1025             or puke "op '$op' with multicols: tuple with improper number of cols";
1026 3         8 push @bind, @$val;
1027             }
1028              
1029             # return the whole thing
1030 2         22 return ($sql, @bind);
1031             }
1032              
1033              
1034              
1035             #----------------------------------------------------------------------
1036             # override of parent's methods for decoding arrayrefs
1037             #----------------------------------------------------------------------
1038              
1039             sub _where_hashpair_ARRAYREF {
1040 0     0   0 my ($self, $k, $v) = @_;
1041              
1042 0 0       0 if ($self->is_bind_value_with_type($v)) {
1043 0         0 $self->_assert_no_bindtype_columns;
1044             my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
1045 0         0 $self->_sqlcase($self->{cmp}),
1046             $self->_convert('?');
1047 0         0 my @bind = ($v);
1048 0         0 return ($sql, @bind);
1049             }
1050             else {
1051 0         0 return $self->next::method($k, $v);
1052             }
1053             }
1054              
1055              
1056             sub _where_field_op_ARRAYREF {
1057 0     0   0 my ($self, $k, $op, $vals) = @_;
1058              
1059 0 0       0 if ($self->is_bind_value_with_type($vals)) {
1060 0         0 $self->_assert_no_bindtype_columns;
1061 0         0 my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
1062             $self->_sqlcase($op),
1063             $self->_convert('?');
1064 0         0 my @bind = ($vals);
1065 0         0 return ($sql, @bind);
1066             }
1067             else {
1068 0         0 return $self->next::method($k, $op, $vals);
1069             }
1070             }
1071              
1072             sub _assert_no_bindtype_columns {
1073 0     0   0 my ($self) = @_;
1074 0 0       0 $self->{bindtype} ne 'columns'
1075             or puke 'values of shape [$val, \%type] are not compatible'
1076             . 'with ...->new(bindtype => "columns")';
1077             }
1078              
1079              
1080             sub _insert_value { # called from _insert_values() in parent class
1081              
1082             # unfortunately, we can't just override the ARRAYREF part, so the whole
1083             # parent method is copied here
1084              
1085 0     0   0 my ($self, $column, $v) = @_;
1086              
1087 0         0 my (@values, @all_bind);
1088             $self->_SWITCH_refkind($v, {
1089              
1090             ARRAYREF => sub {
1091 0 0 0 0   0 if ($self->{array_datatypes} # if array datatype are activated
1092             || $self->is_bind_value_with_type($v)) { # or if this is a bind val
1093 0         0 push @values, '?';
1094 0         0 push @all_bind, $self->_bindtype($column, $v);
1095             }
1096             else { # else literal SQL with bind
1097 0         0 my ($sql, @bind) = @$v;
1098 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1099 0         0 push @values, $sql;
1100 0         0 push @all_bind, @bind;
1101             }
1102             },
1103              
1104             ARRAYREFREF => sub { # literal SQL with bind
1105 0     0   0 my ($sql, @bind) = @${$v};
  0         0  
1106 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1107 0         0 push @values, $sql;
1108 0         0 push @all_bind, @bind;
1109             },
1110              
1111             # THINK : anything useful to do with a HASHREF ?
1112             HASHREF => sub { # (nothing, but old SQLA passed it through)
1113             #TODO in SQLA >= 2.0 it will die instead
1114 0     0   0 SQL::Abstract::belch "HASH ref as bind value in insert is not supported";
1115 0         0 push @values, '?';
1116 0         0 push @all_bind, $self->_bindtype($column, $v);
1117             },
1118              
1119             SCALARREF => sub { # literal SQL without bind
1120 0     0   0 push @values, $$v;
1121             },
1122              
1123             SCALAR_or_UNDEF => sub {
1124 0     0   0 push @values, '?';
1125 0         0 push @all_bind, $self->_bindtype($column, $v);
1126             },
1127              
1128 0         0 });
1129              
1130 0         0 my $sql = CORE::join(", ", @values);
1131 0         0 return ($sql, @all_bind);
1132             }
1133              
1134              
1135              
1136              
1137              
1138             sub _update_set_values { # called from update() in parent class
1139 0     0   0 my ($self, $data) = @_;
1140              
1141 0         0 my (@set, @all_bind);
1142 0         0 for my $k (sort keys %$data) {
1143 0         0 my $v = $data->{$k};
1144 0         0 my $r = ref $v;
1145 0         0 my $label = $self->_quote($k);
1146              
1147             $self->_SWITCH_refkind($v, {
1148             ARRAYREF => sub {
1149 0 0 0 0   0 if ($self->{array_datatypes} # array datatype
1150             || $self->is_bind_value_with_type($v)) { # or bind value with type
1151 0         0 push @set, "$label = ?";
1152 0         0 push @all_bind, $self->_bindtype($k, $v);
1153             }
1154             else { # literal SQL with bind
1155 0         0 my ($sql, @bind) = @$v;
1156 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1157 0         0 push @set, "$label = $sql";
1158 0         0 push @all_bind, @bind;
1159             }
1160             },
1161             ARRAYREFREF => sub { # literal SQL with bind
1162 0     0   0 my ($sql, @bind) = @${$v};
  0         0  
1163 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1164 0         0 push @set, "$label = $sql";
1165 0         0 push @all_bind, @bind;
1166             },
1167             SCALARREF => sub { # literal SQL without bind
1168 0     0   0 push @set, "$label = $$v";
1169             },
1170             HASHREF => sub {
1171 0     0   0 my ($op, $arg, @rest) = %$v;
1172              
1173 0 0 0     0 puke 'Operator calls in update must be in the form { -op => $arg }'
1174             if (@rest or not $op =~ /^\-(.+)/);
1175              
1176 0         0 local $self->{_nested_func_lhs} = $k;
1177 0         0 my ($sql, @bind) = $self->_where_unary_op($1, $arg);
1178              
1179 0         0 push @set, "$label = $sql";
1180 0         0 push @all_bind, @bind;
1181             },
1182             SCALAR_or_UNDEF => sub {
1183 0     0   0 push @set, "$label = ?";
1184 0         0 push @all_bind, $self->_bindtype($k, $v);
1185             },
1186 0         0 });
1187             }
1188              
1189             # generate sql
1190 0         0 my $sql = CORE::join ', ', @set;
1191              
1192 0         0 return ($sql, @all_bind);
1193             }
1194              
1195              
1196              
1197              
1198              
1199              
1200             #----------------------------------------------------------------------
1201             # method creations through closures
1202             #----------------------------------------------------------------------
1203              
1204             sub _make_sub_column_alias {
1205 18     18   42 my ($self) = @_;
1206 18         42 my $syntax = $self->{column_alias};
1207             $self->{column_alias} = sub {
1208 16     16   70 my ($self, $name, $alias) = @_;
1209 16 100       50 return $name if !$alias;
1210              
1211             # quote $name unless it is an SQL expression (then the user should quote it)
1212 15 100       61 $name = $self->_quote($name) unless $name =~ /[()]/;
1213              
1214             # assemble syntax
1215 15         197 my $sql = sprintf $syntax, $name, $self->_quote($alias);
1216              
1217             # return a string ref to avoid quoting by SQLA
1218 15         249 return \$sql;
1219 18         91 };
1220             }
1221              
1222              
1223             sub _make_sub_table_alias {
1224 18     18   39 my ($self) = @_;
1225 18         42 my $syntax = $self->{table_alias};
1226             $self->{table_alias} = sub {
1227 65     65   113 my ($self, $name, $alias) = @_;
1228 65 100       390 return $name if !$alias;
1229              
1230             # assemble syntax
1231 14         41 my $sql = sprintf $syntax, $self->_quote($name), $self->_quote($alias);
1232              
1233 14         512 return $sql;
1234 18         132 };
1235             }
1236              
1237              
1238              
1239             sub _choose_LIMIT_OFFSET_dialect {
1240 17     17   29 my $self = shift;
1241 17         46 my $dialect = $self->{limit_offset};
1242 17 50       60 my $method = $limit_offset_dialects{$dialect}
1243             or puke "no such limit_offset dialect: $dialect";
1244 17         34 $self->{limit_offset} = $method;
1245             }
1246              
1247              
1248             #----------------------------------------------------------------------
1249             # utility to decide if the method was called with named or positional args
1250             #----------------------------------------------------------------------
1251              
1252             sub _called_with_named_args {
1253 85   66 85   582 return $_[0] && !ref $_[0] && substr($_[0], 0, 1) eq '-';
1254             }
1255              
1256              
1257             1; # End of SQL::Abstract::More
1258              
1259             __END__