File Coverage

blib/lib/DBIx/Class/ResultSet.pm
Criterion Covered Total %
statement 977 1059 92.2
branch 557 672 82.8
condition 246 355 69.3
subroutine 88 95 92.6
pod 43 45 95.5
total 1911 2226 85.8


line stmt bran cond sub pod time code
1             package DBIx::Class::ResultSet;
2              
3 379     379   2350 use strict;
  379         752  
  379         9989  
4 379     379   1449 use warnings;
  379         693  
  379         10113  
5 379     379   1427 use base qw/DBIx::Class/;
  379         662  
  379         27154  
6 379     379   1892 use DBIx::Class::Carp;
  379         791  
  379         2936  
7 379     379   154128 use DBIx::Class::ResultSetColumn;
  379         827  
  379         14339  
8 379     379   2229 use Scalar::Util qw/blessed weaken reftype/;
  379         681  
  379         21910  
9 379         17004 use DBIx::Class::_Util qw(
10             fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION
11 379     379   1698 );
  379         687  
12 379     379   2002 use Try::Tiny;
  379         728  
  379         17638  
13              
14             # not importing first() as it will clash with our own method
15 379     379   1681 use List::Util ();
  379         683  
  379         15313  
16              
17             BEGIN {
18             # De-duplication in _merge_attr() is disabled, but left in for reference
19             # (the merger is used for other things that ought not to be de-duped)
20 379     379   6437 *__HM_DEDUP = sub () { 0 };
21             }
22              
23 379     379   1625 use namespace::clean;
  379         744  
  379         1561  
24              
25             use overload
26 379         3122 '0+' => "count",
27             'bool' => "_bool",
28 379     379   102178 fallback => 1;
  379         738  
29              
30             # this is real - CDBICompat overrides it with insanity
31             # yes, prototype won't matter, but that's for now ;)
32             sub _bool () { 1 }
33              
34             __PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/);
35              
36             =head1 NAME
37              
38             DBIx::Class::ResultSet - Represents a query used for fetching a set of results.
39              
40             =head1 SYNOPSIS
41              
42             my $users_rs = $schema->resultset('User');
43             while( $user = $users_rs->next) {
44             print $user->username;
45             }
46              
47             my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 });
48             my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all();
49              
50             =head1 DESCRIPTION
51              
52             A ResultSet is an object which stores a set of conditions representing
53             a query. It is the backbone of DBIx::Class (i.e. the really
54             important/useful bit).
55              
56             No SQL is executed on the database when a ResultSet is created, it
57             just stores all the conditions needed to create the query.
58              
59             A basic ResultSet representing the data of an entire table is returned
60             by calling C on a L and passing in a
61             L name.
62              
63             my $users_rs = $schema->resultset('User');
64              
65             A new ResultSet is returned from calling L on an existing
66             ResultSet. The new one will contain all the conditions of the
67             original, plus any new conditions added in the C call.
68              
69             A ResultSet also incorporates an implicit iterator. L and L
70             can be used to walk through all the Ls the ResultSet
71             represents.
72              
73             The query that the ResultSet represents is B executed against
74             the database when these methods are called:
75             L, L, L, L, L, L.
76              
77             If a resultset is used in a numeric context it returns the L.
78             However, if it is used in a boolean context it is B true. So if
79             you want to check if a resultset has any results, you must use C
80             != 0>.
81              
82             =head1 EXAMPLES
83              
84             =head2 Chaining resultsets
85              
86             Let's say you've got a query that needs to be run to return some data
87             to the user. But, you have an authorization system in place that
88             prevents certain users from seeing certain information. So, you want
89             to construct the basic query in one method, but add constraints to it in
90             another.
91              
92             sub get_data {
93             my $self = shift;
94             my $request = $self->get_request; # Get a request object somehow.
95             my $schema = $self->result_source->schema;
96              
97             my $cd_rs = $schema->resultset('CD')->search({
98             title => $request->param('title'),
99             year => $request->param('year'),
100             });
101              
102             $cd_rs = $self->apply_security_policy( $cd_rs );
103              
104             return $cd_rs->all();
105             }
106              
107             sub apply_security_policy {
108             my $self = shift;
109             my ($rs) = @_;
110              
111             return $rs->search({
112             subversive => 0,
113             });
114             }
115              
116             =head3 Resolving conditions and attributes
117              
118             When a resultset is chained from another resultset (e.g.:
119             C<< my $new_rs = $old_rs->search(\%extra_cond, \%attrs) >>), conditions
120             and attributes with the same keys need resolving.
121              
122             If any of L, L, L are present, they reset the
123             original selection, and start the selection "clean".
124              
125             The L, L, L, L, L attributes
126             are merged into the existing ones from the original resultset.
127              
128             The L and L attributes, and any search conditions, are
129             merged with an SQL C to the existing condition from the original
130             resultset.
131              
132             All other attributes are overridden by any new ones supplied in the
133             search attributes.
134              
135             =head2 Multiple queries
136              
137             Since a resultset just defines a query, you can do all sorts of
138             things with it with the same object.
139              
140             # Don't hit the DB yet.
141             my $cd_rs = $schema->resultset('CD')->search({
142             title => 'something',
143             year => 2009,
144             });
145              
146             # Each of these hits the DB individually.
147             my $count = $cd_rs->count;
148             my $most_recent = $cd_rs->get_column('date_released')->max();
149             my @records = $cd_rs->all;
150              
151             And it's not just limited to SELECT statements.
152              
153             $cd_rs->delete();
154              
155             This is even cooler:
156              
157             $cd_rs->create({ artist => 'Fred' });
158              
159             Which is the same as:
160              
161             $schema->resultset('CD')->create({
162             title => 'something',
163             year => 2009,
164             artist => 'Fred'
165             });
166              
167             See: L, L, L, L, L.
168              
169             =head2 Custom ResultSet classes
170              
171             To add methods to your resultsets, you can subclass L, similar to:
172              
173             package MyApp::Schema::ResultSet::User;
174              
175             use strict;
176             use warnings;
177              
178             use base 'DBIx::Class::ResultSet';
179              
180             sub active {
181             my $self = shift;
182             $self->search({ $self->current_source_alias . '.active' => 1 });
183             }
184              
185             sub unverified {
186             my $self = shift;
187             $self->search({ $self->current_source_alias . '.verified' => 0 });
188             }
189              
190             sub created_n_days_ago {
191             my ($self, $days_ago) = @_;
192             $self->search({
193             $self->current_source_alias . '.create_date' => {
194             '<=',
195             $self->result_source->schema->storage->datetime_parser->format_datetime(
196             DateTime->now( time_zone => 'UTC' )->subtract( days => $days_ago )
197             )}
198             });
199             }
200              
201             sub users_to_warn { shift->active->unverified->created_n_days_ago(7) }
202              
203             1;
204              
205             See L on how DBIC can discover and
206             automatically attach L-specific
207             L classes.
208              
209             =head3 ResultSet subclassing with Moose and similar constructor-providers
210              
211             Using L or L in your ResultSet classes is usually overkill, but
212             you may find it useful if your ResultSets contain a lot of business logic
213             (e.g. C, C, etc) or if you just prefer to organize
214             your code via roles.
215              
216             In order to write custom ResultSet classes with L you need to use the
217             following template. The L is necessary due to the
218             unusual signature of the L
219             |DBIx::Class::ResultSet/new> C<< ->new($source, \%args) >>.
220              
221             use Moo;
222             extends 'DBIx::Class::ResultSet';
223             sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_
224              
225             ...your code...
226              
227             1;
228              
229             If you want to build your custom ResultSet classes with L, you need
230             a similar, though a little more elaborate template in order to interface the
231             inlining of the L-provided
232             L,
233             with the DBIC one.
234              
235             package MyApp::Schema::ResultSet::User;
236              
237             use Moose;
238             use MooseX::NonMoose;
239             extends 'DBIx::Class::ResultSet';
240              
241             sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_
242              
243             ...your code...
244              
245             __PACKAGE__->meta->make_immutable;
246              
247             1;
248              
249             The L is necessary so that the L constructor does not
250             entirely overwrite the DBIC one (in contrast L does this automatically).
251             Alternatively, you can skip L and get by with just L
252             instead by doing:
253              
254             __PACKAGE__->meta->make_immutable(inline_constructor => 0);
255              
256             =head1 METHODS
257              
258             =head2 new
259              
260             =over 4
261              
262             =item Arguments: L<$source|DBIx::Class::ResultSource>, L<\%attrs?|/ATTRIBUTES>
263              
264             =item Return Value: L<$resultset|/search>
265              
266             =back
267              
268             The resultset constructor. Takes a source object (usually a
269             L) and an attribute hash (see
270             L below). Does not perform any queries -- these are
271             executed as needed by the other methods.
272              
273             Generally you never construct a resultset manually. Instead you get one
274             from e.g. a
275             C<< $schema->L('$source_name') >>
276             or C<< $another_resultset->L(...) >> (the later called in
277             scalar context):
278              
279             my $rs = $schema->resultset('CD')->search({ title => '100th Window' });
280              
281             =over
282              
283             =item WARNING
284              
285             If called on an object, proxies to L instead, so
286              
287             my $cd = $schema->resultset('CD')->new({ title => 'Spoon' });
288              
289             will return a CD object, not a ResultSet, and is equivalent to:
290              
291             my $cd = $schema->resultset('CD')->new_result({ title => 'Spoon' });
292              
293             Please also keep in mind that many internals call L directly,
294             so overloading this method with the idea of intercepting new result object
295             creation B. See also warning pertaining to L.
296              
297             =back
298              
299             =cut
300              
301             sub new {
302 32952     32952 1 40658 my $class = shift;
303              
304 32952 100       62683 if (ref $class) {
305 21         30 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
306 21         117 return $class->new_result(@_);
307             }
308              
309 32931         38379 my ($source, $attrs) = @_;
310 32931 100       173377 $source = $source->resolve
311             if $source->isa('DBIx::Class::ResultSourceHandle');
312              
313 32931 100       28359 $attrs = { %{$attrs||{}} };
  32931         134038  
314 32931         42052 delete @{$attrs}{qw(_last_sqlmaker_alias_map _simple_passthrough_construction)};
  32931         44930  
315              
316 32931 100       64141 if ($attrs->{page}) {
317 26   100     80 $attrs->{rows} ||= 10;
318             }
319              
320 32931   100     93422 $attrs->{alias} ||= 'me';
321              
322             my $self = bless {
323             result_source => $source,
324             cond => $attrs->{where},
325 32931         109983 pager => undef,
326             attrs => $attrs,
327             }, $class;
328              
329             # if there is a dark selector, this means we are already in a
330             # chain and the cleanup/sanification was taken care of by
331             # _search_rs already
332             $self->_normalize_selection($attrs)
333 32931 100       94420 unless $attrs->{_dark_selector};
334              
335             $self->result_class(
336 32931   66     793639 $attrs->{result_class} || $source->result_class
337             );
338              
339 32929         139965 $self;
340             }
341              
342             =head2 search
343              
344             =over 4
345              
346             =item Arguments: L<$cond|DBIx::Class::SQLMaker> | undef, L<\%attrs?|/ATTRIBUTES>
347              
348             =item Return Value: $resultset (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context)
349              
350             =back
351              
352             my @cds = $cd_rs->search({ year => 2001 }); # "... WHERE year = 2001"
353             my $new_rs = $cd_rs->search({ year => 2005 });
354              
355             my $new_rs = $cd_rs->search([ { year => 2005 }, { year => 2004 } ]);
356             # year = 2005 OR year = 2004
357              
358             In list context, C<< ->all() >> is called implicitly on the resultset, thus
359             returning a list of L objects instead.
360             To avoid that, use L.
361              
362             If you need to pass in additional attributes but no additional condition,
363             call it as C.
364              
365             # "SELECT name, artistid FROM $artist_table"
366             my @all_artists = $schema->resultset('Artist')->search(undef, {
367             columns => [qw/name artistid/],
368             });
369              
370             For a list of attributes that can be passed to C, see
371             L. For more examples of using this function, see
372             L. For a complete
373             documentation for the first argument, see L
374             and its extension L.
375              
376             For more help on using joins with search, see L.
377              
378             =head3 CAVEAT
379              
380             Note that L does not process/deflate any of the values passed in the
381             L-compatible search condition structure. This is unlike other
382             condition-bound methods L, L and L. The user must ensure
383             manually that any value passed to this method will stringify to something the
384             RDBMS knows how to deal with. A notable example is the handling of L
385             objects, for more info see:
386             L.
387              
388             =cut
389              
390             sub search {
391 16492     16492 1 740926 my $self = shift;
392 16492         33018 my $rs = $self->search_rs( @_ );
393              
394 16484 100       37911 if (wantarray) {
    100          
395 85         106 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray;
396 85         295 return $rs->all;
397             }
398             elsif (defined wantarray) {
399 16398         83121 return $rs;
400             }
401             else {
402             # we can be called by a relationship helper, which in
403             # turn may be called in void context due to some braindead
404             # overload or whatever else the user decided to be clever
405             # at this particular day. Thus limit the exception to
406             # external code calls only
407 1 50       6 $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
408             if (caller)[0] !~ /^\QDBIx::Class::/;
409              
410 0         0 return ();
411             }
412             }
413              
414             =head2 search_rs
415              
416             =over 4
417              
418             =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES>
419              
420             =item Return Value: L<$resultset|/search>
421              
422             =back
423              
424             This method does the same exact thing as search() except it will
425             always return a resultset, even in list context.
426              
427             =cut
428              
429             sub search_rs {
430 17480     17480 1 17375 my $self = shift;
431              
432 17480         29579 my $rsrc = $self->result_source;
433 17480         17610 my ($call_cond, $call_attrs);
434              
435             # Special-case handling for (undef, undef) or (undef)
436             # Note that (foo => undef) is valid deprecated syntax
437 17480 100       27244 @_ = () if not scalar grep { defined $_ } @_;
  22493         52885  
438              
439             # just a cond
440 17480 100 100     86188 if (@_ == 1) {
    100 66        
    100          
    100          
441 5593         5804 $call_cond = shift;
442             }
443             # fish out attrs in the ($condref, $attr) case
444             elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) {
445 8440         12131 ($call_cond, $call_attrs) = @_;
446             }
447             elsif (@_ % 2) {
448 6         15 $self->throw_exception('Odd number of arguments to search')
449             }
450             # legacy search
451             elsif (@_) {
452 1 50       18 carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead'
453             unless $rsrc->result_class->isa('DBIx::Class::CDBICompat');
454              
455 1         74 for my $i (0 .. $#_) {
456 2 100       6 next if $i % 2;
457 1 50 33     7 $self->throw_exception ('All keys in condition key/value pairs must be plain scalars')
458             if (! defined $_[$i] or ref $_[$i] ne '');
459             }
460              
461 1         3 $call_cond = { @_ };
462             }
463              
464             # see if we can keep the cache (no $rs changes)
465 17474         15149 my $cache;
466 17474         44514 my %safe = (alias => 1, cache => 1);
467 17474 100 66 8555   152507 if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and (
  8555   66     24402  
468             ! defined $call_cond
469             or
470             ref $call_cond eq 'HASH' && ! keys %$call_cond
471             or
472             ref $call_cond eq 'ARRAY' && ! @$call_cond
473             )) {
474 3636         7505 $cache = $self->get_cache;
475             }
476              
477 17474         41194 my $old_attrs = { %{$self->{attrs}} };
  17474         69904  
478 17474         23322 my ($old_having, $old_where) = delete @{$old_attrs}{qw(having where)};
  17474         32179  
479              
480 17474         45520 my $new_attrs = { %$old_attrs };
481              
482             # take care of call attrs (only if anything is changing)
483 17474 100 66     74978 if ($call_attrs and keys %$call_attrs) {
484              
485             # copy for _normalize_selection
486 8435         21779 $call_attrs = { %$call_attrs };
487              
488 8435         25351 my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/;
489              
490             # reset the current selector list if new selectors are supplied
491 8435 100   29805   28555 if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) {
  29805         35653  
492 1648         2381 delete @{$old_attrs}{(@selector_attrs, '_dark_selector')};
  1648         3618  
493             }
494              
495             # Normalize the new selector list (operates on the passed-in attr structure)
496             # Need to do it on every chain instead of only once on _resolved_attrs, in
497             # order to allow detection of empty vs partial 'as'
498             $call_attrs->{_dark_selector} = $old_attrs->{_dark_selector}
499 8435 100       26039 if $old_attrs->{_dark_selector};
500 8435         17489 $self->_normalize_selection ($call_attrs);
501              
502             # start with blind overwriting merge, exclude selector attrs
503 8433         8261 $new_attrs = { %{$old_attrs}, %{$call_attrs} };
  8433         13380  
  8433         29606  
504 8433         17541 delete @{$new_attrs}{@selector_attrs};
  8433         15582  
505              
506 8433         12573 for (@selector_attrs) {
507             $new_attrs->{$_} = $self->_merge_attr($old_attrs->{$_}, $call_attrs->{$_})
508 67464 100 66     160284 if ( exists $old_attrs->{$_} or exists $call_attrs->{$_} );
509             }
510              
511             # older deprecated name, use only if {columns} is not there
512 8433 100       19388 if (my $c = delete $new_attrs->{cols}) {
513 1         28 carp_unique( "Resultset attribute 'cols' is deprecated, use 'columns' instead" );
514 1 50       77 if ($new_attrs->{columns}) {
515 0         0 carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'";
516             }
517             else {
518 1         3 $new_attrs->{columns} = $c;
519             }
520             }
521              
522              
523             # join/prefetch use their own crazy merging heuristics
524 8433         11578 foreach my $key (qw/join prefetch/) {
525             $new_attrs->{$key} = $self->_merge_joinpref_attr($old_attrs->{$key}, $call_attrs->{$key})
526 16866 100       32737 if exists $call_attrs->{$key};
527             }
528              
529             # stack binds together
530 8433 100       8331 $new_attrs->{bind} = [ @{ $old_attrs->{bind} || [] }, @{ $call_attrs->{bind} || [] } ];
  8433 100       29245  
  8433         39776  
531             }
532              
533              
534 17472         26051 for ($old_where, $call_cond) {
535 34944 100       59037 if (defined $_) {
536             $new_attrs->{where} = $self->_stack_cond (
537             $_, $new_attrs->{where}
538 21718         56650 );
539             }
540             }
541              
542 17472 100       30329 if (defined $old_having) {
543             $new_attrs->{having} = $self->_stack_cond (
544             $old_having, $new_attrs->{having}
545             )
546 27         93 }
547              
548 17472         48522 my $rs = (ref $self)->new($rsrc, $new_attrs);
549              
550 17470 100       32945 $rs->set_cache($cache) if ($cache);
551              
552 17470         79690 return $rs;
553             }
554              
555             my $dark_sel_dumper;
556             sub _normalize_selection {
557 41339     41339   45153 my ($self, $attrs) = @_;
558              
559             # legacy syntax
560 41339 100       74266 if ( exists $attrs->{include_columns} ) {
561 1         7 carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" );
562             $attrs->{'+columns'} = $self->_merge_attr(
563             $attrs->{'+columns'}, delete $attrs->{include_columns}
564 1         61 );
565             }
566              
567             # columns are always placed first, however
568              
569             # Keep the X vs +X separation until _resolved_attrs time - this allows to
570             # delay the decision on whether to use a default select list ($rsrc->columns)
571             # allowing stuff like the remove_columns helper to work
572             #
573             # select/as +select/+as pairs need special handling - the amount of select/as
574             # elements in each pair does *not* have to be equal (think multicolumn
575             # selectors like distinct(foo, bar) ). If the selector is bare (no 'as'
576             # supplied at all) - try to infer the alias, either from the -as parameter
577             # of the selector spec, or use the parameter whole if it looks like a column
578             # name (ugly legacy heuristic). If all fails - leave the selector bare (which
579             # is ok as well), but make sure no more additions to the 'as' chain take place
580 41339         54236 for my $pref ('', '+') {
581              
582             my ($sel, $as) = map {
583 82678         81779 my $key = "${pref}${_}";
  165356         166729  
584              
585             my $val = [ ref $attrs->{$key} eq 'ARRAY'
586 2358         4198 ? @{$attrs->{$key}}
587 165356 100 66     520505 : $attrs->{$key} || ()
588             ];
589 165356         138484 delete $attrs->{$key};
590 165356         216166 $val;
591             } qw/select as/;
592              
593 82678 100 100     276883 if (! @$as and ! @$sel ) {
    50 66        
    100 66        
    50          
    100          
594 80443         119320 next;
595             }
596             elsif (@$as and ! @$sel) {
597 0         0 $self->throw_exception(
598             "Unable to handle ${pref}as specification (@$as) without a corresponding ${pref}select"
599             );
600             }
601             elsif( ! @$as ) {
602             # no as part supplied at all - try to deduce (unless explicit end of named selection is declared)
603             # if any @$as has been supplied we assume the user knows what (s)he is doing
604             # and blindly keep stacking up pieces
605 599 100       1524 unless ($attrs->{_dark_selector}) {
606             SELECTOR:
607 594         1360 for (@$sel) {
608 660 100 100     5976 if ( ref $_ eq 'HASH' and exists $_->{-as} ) {
    100 66        
609 5         29 push @$as, $_->{-as};
610             }
611             # assume any plain no-space, no-parenthesis string to be a column spec
612             # FIXME - this is retarded but is necessary to support shit like 'count(foo)'
613             elsif ( ! ref $_ and $_ =~ /^ [^\s\(\)]+ $/x) {
614 634         1520 push @$as, $_;
615             }
616             # if all else fails - raise a flag that no more aliasing will be allowed
617             else {
618             $attrs->{_dark_selector} = {
619             plus_stage => $pref,
620 21   66     140 string => ($dark_sel_dumper ||= do {
621 9         64 require Data::Dumper::Concise;
622 9         45 Data::Dumper::Concise::DumperObject()->Indent(0);
623             })->Values([$_])->Dump
624             ,
625             };
626 21         5553 last SELECTOR;
627             }
628             }
629             }
630             }
631             elsif (@$as < @$sel) {
632 0         0 $self->throw_exception(
633             "Unable to handle an ${pref}as specification (@$as) with less elements than the corresponding ${pref}select"
634             );
635             }
636             elsif ($pref and $attrs->{_dark_selector}) {
637 2         16 $self->throw_exception(
638             "Unable to process named '+select', resultset contains an unnamed selector $attrs->{_dark_selector}{string}"
639             );
640             }
641              
642              
643             # merge result
644 2233         8831 $attrs->{"${pref}select"} = $self->_merge_attr($attrs->{"${pref}select"}, $sel);
645 2233         7999 $attrs->{"${pref}as"} = $self->_merge_attr($attrs->{"${pref}as"}, $as);
646             }
647             }
648              
649             sub _stack_cond {
650 21745     21745   41172 my ($self, $left, $right) = @_;
651              
652             (
653             (ref $_ eq 'ARRAY' and !@$_)
654             or
655             (ref $_ eq 'HASH' and ! keys %$_)
656 21745   33     211333 ) and $_ = undef for ($left, $right);
      100        
657              
658             # either one of the two undef
659 21745 100 100     80223 if ( (defined $left) xor (defined $right) ) {
    100          
660 16856 100       58432 return defined $left ? $left : $right;
661             }
662             # both undef
663             elsif ( ! defined $left ) {
664             return undef
665 968         2983 }
666             else {
667 3921         16467 return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] });
668             }
669             }
670              
671             =head2 search_literal
672              
673             B: C is provided for Class::DBI compatibility and
674             should only be used in that context. C is a convenience
675             method. It is equivalent to calling C<< $schema->search(\[]) >>, but if you
676             want to ensure columns are bound correctly, use L.
677              
678             See L and
679             L for searching techniques that do not
680             require C.
681              
682             =over 4
683              
684             =item Arguments: $sql_fragment, @standalone_bind_values
685              
686             =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context)
687              
688             =back
689              
690             my @cds = $cd_rs->search_literal('year = ? AND title = ?', qw/2001 Reload/);
691             my $newrs = $artist_rs->search_literal('name = ?', 'Metallica');
692              
693             Pass a literal chunk of SQL to be added to the conditional part of the
694             resultset query.
695              
696             Example of how to use C instead of C
697              
698             my @cds = $cd_rs->search_literal('cdid = ? AND (artist = ? OR artist = ?)', (2, 1, 2));
699             my @cds = $cd_rs->search(\[ 'cdid = ? AND (artist = ? OR artist = ?)', [ 'cdid', 2 ], [ 'artist', 1 ], [ 'artist', 2 ] ]);
700              
701             =cut
702              
703             sub search_literal {
704 1     1 1 3 my ($self, $sql, @bind) = @_;
705 1         1 my $attr;
706 1 50 33     5 if ( @bind && ref($bind[-1]) eq 'HASH' ) {
707 0         0 $attr = pop @bind;
708             }
709 1   33     14 return $self->search(\[ $sql, map [ {} => $_ ], @bind ], ($attr || () ));
710             }
711              
712             =head2 find
713              
714             =over 4
715              
716             =item Arguments: \%columns_values | @pk_values, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }?
717              
718             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef
719              
720             =back
721              
722             Finds and returns a single row based on supplied criteria. Takes either a
723             hashref with the same format as L (including inference of foreign
724             keys from related objects), or a list of primary key values in the same
725             order as the L
726             declaration on the L.
727              
728             In either case an attempt is made to combine conditions already existing on
729             the resultset with the condition passed to this method.
730              
731             To aid with preparing the correct query for the storage you may supply the
732             C attribute, which is the name of a
733             L (the
734             unique constraint corresponding to the
735             L is always named
736             C). If the C attribute has been supplied, and DBIC is unable
737             to construct a query that satisfies the named unique constraint fully (
738             non-NULL values for each column member of the constraint) an exception is
739             thrown.
740              
741             If no C is specified, the search is carried over all unique constraints
742             which are fully defined by the available condition.
743              
744             If no such constraint is found, C currently defaults to a simple
745             C<< search->(\%column_values) >> which may or may not do what you expect.
746             Note that this fallback behavior may be deprecated in further versions. If
747             you need to search with arbitrary conditions - use L. If the query
748             resulting from this fallback produces more than one row, a warning to the
749             effect is issued, though only the first row is constructed and returned as
750             C<$result_object>.
751              
752             In addition to C, L recognizes and applies standard
753             L in the same way as L does.
754              
755             Note that if you have extra concerns about the correctness of the resulting
756             query you need to specify the C attribute and supply the entire condition
757             as an argument to find (since it is not always possible to perform the
758             combination of the resultset condition with the supplied one, especially if
759             the resultset condition contains literal sql).
760              
761             For example, to find a row by its primary key:
762              
763             my $cd = $schema->resultset('CD')->find(5);
764              
765             You can also find a row by a specific unique constraint:
766              
767             my $cd = $schema->resultset('CD')->find(
768             {
769             artist => 'Massive Attack',
770             title => 'Mezzanine',
771             },
772             { key => 'cd_artist_title' }
773             );
774              
775             See also L and L.
776              
777             =cut
778              
779             sub find {
780 1381     1381 1 41187 my $self = shift;
781 1381 100 100     7219 my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
782              
783 1381         3391 my $rsrc = $self->result_source;
784              
785 1381         1916 my $constraint_name;
786 1381 100       4030 if (exists $attrs->{key}) {
787             $constraint_name = defined $attrs->{key}
788             ? $attrs->{key}
789 18 50       48 : $self->throw_exception("An undefined 'key' resultset attribute makes no sense")
790             ;
791             }
792              
793             # Parse out the condition from input
794 1381         1650 my $call_cond;
795              
796 1381 100       4169 if (ref $_[0] eq 'HASH') {
797 1166         1833 $call_cond = { %{$_[0]} };
  1166         3998  
798             }
799             else {
800             # if only values are supplied we need to default to 'primary'
801 215 100       716 $constraint_name = 'primary' unless defined $constraint_name;
802              
803 215         1279 my @c_cols = $rsrc->unique_constraint_columns($constraint_name);
804              
805 215 50       619 $self->throw_exception(
806             "No constraint columns, maybe a malformed '$constraint_name' constraint?"
807             ) unless @c_cols;
808              
809 215 100       654 $self->throw_exception (
810             'find() expects either a column/value hashref, or a list of values '
811             . "corresponding to the columns of the specified unique constraint '$constraint_name'"
812             ) unless @c_cols == @_;
813              
814 214         436 @{$call_cond}{@c_cols} = @_;
  214         674  
815             }
816              
817             # process relationship data if any
818 1380         4149 for my $key (keys %$call_cond) {
819 1274 100 100     4760 if (
      100        
820             length ref($call_cond->{$key})
821             and
822             my $relinfo = $rsrc->relationship_info($key)
823             and
824             # implicitly skip has_many's (likely MC)
825             (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' )
826             ) {
827             my ($rel_cond, $crosstable) = $rsrc->_resolve_condition(
828 19         116 $relinfo->{cond}, $val, $key, $key
829             );
830              
831 18 50 33     115 $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()")
832             if $crosstable or ref($rel_cond) ne 'HASH';
833              
834             # supplement condition
835             # relationship conditions take precedence (?)
836 18         55 @{$call_cond}{keys %$rel_cond} = values %$rel_cond;
  18         66  
837             }
838             }
839              
840 1379 50       4790 my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias};
841 1379         1596 my $final_cond;
842 1379 100 100     6916 if (defined $constraint_name) {
    100          
843 231         1213 $final_cond = $self->_qualify_cond_columns (
844              
845             $self->result_source->_minimal_valueset_satisfying_constraint(
846             constraint_name => $constraint_name,
847             values => ($self->_merge_with_rscond($call_cond))[0],
848             carp_on_nulls => 1,
849             ),
850              
851             $alias,
852             );
853             }
854             elsif ($self->{attrs}{accessor} and $self->{attrs}{accessor} eq 'single') {
855             # This means that we got here after a merger of relationship conditions
856             # in ::Relationship::Base::search_related (the row method), and furthermore
857             # the relationship is of the 'single' type. This means that the condition
858             # provided by the relationship (already attached to $self) is sufficient,
859             # as there can be only one row in the database that would satisfy the
860             # relationship
861             }
862             else {
863 1140         1619 my (@unique_queries, %seen_column_combinations, $ci, @fc_exceptions);
864              
865             # no key was specified - fall down to heuristics mode:
866             # run through all unique queries registered on the resultset, and
867             # 'OR' all qualifying queries together
868             #
869             # always start from 'primary' if it exists at all
870 1140         5172 for my $c_name ( sort {
871 4140 100       9768 $a eq 'primary' ? -1
    100          
872             : $b eq 'primary' ? 1
873             : $a cmp $b
874             } $rsrc->unique_constraint_names) {
875              
876             next if $seen_column_combinations{
877 3801 100       24151 join "\x00", sort $rsrc->unique_constraint_columns($c_name)
878             }++;
879              
880             try {
881 2983   66 2983   139326 push @unique_queries, $self->_qualify_cond_columns(
882             $self->result_source->_minimal_valueset_satisfying_constraint(
883             constraint_name => $c_name,
884             values => ($self->_merge_with_rscond($call_cond))[0],
885             columns_info => ($ci ||= $self->result_source->columns_info),
886             ),
887             $alias
888             );
889             }
890             catch {
891 1951 100   1951   30888 push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/;
892 2983         25313 };
893             }
894              
895             $final_cond =
896             @unique_queries ? \@unique_queries
897 1140 100       8433 : @fc_exceptions ? $self->throw_exception(join "; ", map { $_ =~ /(.*) at .+ line \d+$/s } @fc_exceptions )
  1 100       3  
898             : $self->_non_unique_find_fallback ($call_cond, $attrs)
899             ;
900             }
901              
902             # Run the query, passing the result_class since it should propagate for find
903 1374         5287 my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs});
904 1374 100       5548 if ($rs->_resolved_attrs->{collapse}) {
905 11         60 my $row = $rs->next;
906 11 100       46 carp "Query returned more than one row" if $rs->next;
907 11         112 return $row;
908             }
909             else {
910 1363         5469 return $rs->single;
911             }
912             }
913              
914             # This is a stop-gap method as agreed during the discussion on find() cleanup:
915             # http://lists.scsys.co.uk/pipermail/dbix-class/2010-October/009535.html
916             #
917             # It is invoked when find() is called in legacy-mode with insufficiently-unique
918             # condition. It is provided for overrides until a saner way forward is devised
919             #
920             # *NOTE* This is not a public method, and it's *GUARANTEED* to disappear down
921             # the road. Please adjust your tests accordingly to catch this situation early
922             # DBIx::Class::ResultSet->can('_non_unique_find_fallback') is reasonable
923             #
924             # The method will not be removed without an adequately complete replacement
925             # for strict-mode enforcement
926             sub _non_unique_find_fallback {
927 132     132   255 my ($self, $cond, $attrs) = @_;
928              
929             return $self->_qualify_cond_columns(
930             $cond,
931             exists $attrs->{alias}
932             ? $attrs->{alias}
933             : $self->{attrs}{alias}
934 132 50       709 );
935             }
936              
937              
938             sub _qualify_cond_columns {
939 1391     1391   4070 my ($self, $cond, $alias) = @_;
940              
941 1391         4400 my %aliased = %$cond;
942 1391         3527 for (keys %aliased) {
943 1525 50       8803 $aliased{"$alias.$_"} = delete $aliased{$_}
944             if $_ !~ /\./;
945             }
946              
947 1391         4911 return \%aliased;
948             }
949              
950             sub _build_unique_cond {
951 0     0   0 carp_unique sprintf
952             '_build_unique_cond is a private method, and moreover is about to go '
953             . 'away. Please contact the development team at %s if you believe you '
954             . 'have a genuine use for this method, in order to discuss alternatives.',
955             DBIx::Class::_ENV_::HELP_URL,
956             ;
957              
958 0         0 my ($self, $constraint_name, $cond, $croak_on_null) = @_;
959              
960 0         0 $self->result_source->_minimal_valueset_satisfying_constraint(
961             constraint_name => $constraint_name,
962             values => $cond,
963             carp_on_nulls => !$croak_on_null
964             );
965             }
966              
967             =head2 search_related
968              
969             =over 4
970              
971             =item Arguments: $rel_name, $cond?, L<\%attrs?|/ATTRIBUTES>
972              
973             =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context)
974              
975             =back
976              
977             $new_rs = $cd_rs->search_related('artist', {
978             name => 'Emo-R-Us',
979             });
980              
981             Searches the specified relationship, optionally specifying a condition and
982             attributes for matching records. See L for more information.
983              
984             In list context, C<< ->all() >> is called implicitly on the resultset, thus
985             returning a list of result objects instead. To avoid that, use L.
986              
987             See also L.
988              
989             =cut
990              
991             sub search_related {
992 214     214 1 5684 return shift->related_resultset(shift)->search(@_);
993             }
994              
995             =head2 search_related_rs
996              
997             This method works exactly the same as search_related, except that
998             it guarantees a resultset, even in list context.
999              
1000             =cut
1001              
1002             sub search_related_rs {
1003 1     1 1 18 return shift->related_resultset(shift)->search_rs(@_);
1004             }
1005              
1006             =head2 cursor
1007              
1008             =over 4
1009              
1010             =item Arguments: none
1011              
1012             =item Return Value: L<$cursor|DBIx::Class::Cursor>
1013              
1014             =back
1015              
1016             Returns a storage-driven cursor to the given resultset. See
1017             L for more information.
1018              
1019             =cut
1020              
1021             sub cursor {
1022 10728     10728 1 12086 my $self = shift;
1023              
1024 10728   66     35275 return $self->{cursor} ||= do {
1025 3788         9153 my $attrs = $self->_resolved_attrs;
1026             $self->result_source->storage->select(
1027 3788         16470 $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
1028             );
1029             };
1030             }
1031              
1032             =head2 single
1033              
1034             =over 4
1035              
1036             =item Arguments: L<$cond?|DBIx::Class::SQLMaker>
1037              
1038             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef
1039              
1040             =back
1041              
1042             my $cd = $schema->resultset('CD')->single({ year => 2001 });
1043              
1044             Inflates the first result without creating a cursor if the resultset has
1045             any records in it; if not returns C. Used by L as a lean version
1046             of L.
1047              
1048             While this method can take an optional search condition (just like L)
1049             being a fast-code-path it does not recognize search attributes. If you need to
1050             add extra joins or similar, call L and then chain-call L on the
1051             L returned.
1052              
1053             =over
1054              
1055             =item B
1056              
1057             As of 0.08100, this method enforces the assumption that the preceding
1058             query returns only one row. If more than one row is returned, you will receive
1059             a warning:
1060              
1061             Query returned more than one row
1062              
1063             In this case, you should be using L or L instead, or if you really
1064             know what you are doing, use the L attribute to explicitly limit the size
1065             of the resultset.
1066              
1067             This method will also throw an exception if it is called on a resultset prefetching
1068             has_many, as such a prefetch implies fetching multiple rows from the database in
1069             order to assemble the resulting object.
1070              
1071             =back
1072              
1073             =cut
1074              
1075             sub single {
1076 2704     2704 1 4853 my ($self, $where) = @_;
1077 2704 50       6344 if(@_ > 2) {
1078 0         0 $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()');
1079             }
1080              
1081 2704         2893 my $attrs = { %{$self->_resolved_attrs} };
  2704         6200  
1082              
1083             $self->throw_exception(
1084             'single() can not be used on resultsets collapsing a has_many. Use find( \%cond ) or next() instead'
1085 2704 100       8201 ) if $attrs->{collapse};
1086              
1087 2703 100       5474 if ($where) {
1088 9 50       36 if (defined $attrs->{where}) {
1089             $attrs->{where} = {
1090             '-and' =>
1091 0 0       0 [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
1092 0         0 $where, delete $attrs->{where} ]
1093             };
1094             } else {
1095 9         21 $attrs->{where} = $where;
1096             }
1097             }
1098              
1099             my $data = [ $self->result_source->storage->select_single(
1100             $attrs->{from}, $attrs->{select},
1101 2703         11463 $attrs->{where}, $attrs
1102             )];
1103              
1104 2702 100       10548 return undef unless @$data;
1105 2408         6437 $self->{_stashed_rows} = [ $data ];
1106 2408         7535 $self->_construct_results->[0];
1107             }
1108              
1109             =head2 get_column
1110              
1111             =over 4
1112              
1113             =item Arguments: L<$cond?|DBIx::Class::SQLMaker>
1114              
1115             =item Return Value: L<$resultsetcolumn|DBIx::Class::ResultSetColumn>
1116              
1117             =back
1118              
1119             my $max_length = $rs->get_column('length')->max;
1120              
1121             Returns a L instance for a column of the ResultSet.
1122              
1123             =cut
1124              
1125             sub get_column {
1126 711     711 1 8342 my ($self, $column) = @_;
1127 711         4364 my $new = DBIx::Class::ResultSetColumn->new($self, $column);
1128 711         3504 return $new;
1129             }
1130              
1131             =head2 search_like
1132              
1133             =over 4
1134              
1135             =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES>
1136              
1137             =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context)
1138              
1139             =back
1140              
1141             # WHERE title LIKE '%blue%'
1142             $cd_rs = $rs->search_like({ title => '%blue%'});
1143              
1144             Performs a search, but uses C instead of C<=> as the condition. Note
1145             that this is simply a convenience method retained for ex Class::DBI users.
1146             You most likely want to use L with specific operators.
1147              
1148             For more information, see L.
1149              
1150             This method is deprecated and will be removed in 0.09. Use L
1151             instead. An example conversion is:
1152              
1153             ->search_like({ foo => 'bar' });
1154              
1155             # Becomes
1156              
1157             ->search({ foo => { like => 'bar' } });
1158              
1159             =cut
1160              
1161             sub search_like {
1162 0     0 1 0 my $class = shift;
1163 0         0 carp_unique (
1164             'search_like() is deprecated and will be removed in DBIC version 0.09.'
1165             .' Instead use ->search({ x => { -like => "y%" } })'
1166             .' (note the outer pair of {}s - they are important!)'
1167             );
1168 0 0 0     0 my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
1169 0 0       0 my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_};
  0         0  
1170 0         0 $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
1171 0         0 return $class->search($query, { %$attrs });
1172             }
1173              
1174             =head2 slice
1175              
1176             =over 4
1177              
1178             =item Arguments: $first, $last
1179              
1180             =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context)
1181              
1182             =back
1183              
1184             Returns a resultset or object list representing a subset of elements from the
1185             resultset slice is called on. Indexes are from 0, i.e., to get the first
1186             three records, call:
1187              
1188             my ($one, $two, $three) = $rs->slice(0, 2);
1189              
1190             =cut
1191              
1192             sub slice {
1193 14     14 1 30621 my ($self, $min, $max) = @_;
1194 14         29 my $attrs = {}; # = { %{ $self->{attrs} || {} } };
1195 14   50     123 $attrs->{offset} = $self->{attrs}{offset} || 0;
1196 14         34 $attrs->{offset} += $min;
1197 14 100       56 $attrs->{rows} = ($max ? ($max - $min + 1) : 1);
1198 14         58 return $self->search(undef, $attrs);
1199             }
1200              
1201             =head2 next
1202              
1203             =over 4
1204              
1205             =item Arguments: none
1206              
1207             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef
1208              
1209             =back
1210              
1211             Returns the next element in the resultset (C is there is none).
1212              
1213             Can be used to efficiently iterate over records in the resultset:
1214              
1215             my $rs = $schema->resultset('CD')->search;
1216             while (my $cd = $rs->next) {
1217             print $cd->title;
1218             }
1219              
1220             Note that you need to store the resultset object, and call C on it.
1221             Calling C<< resultset('Table')->next >> repeatedly will always return the
1222             first record from the resultset.
1223              
1224             =cut
1225              
1226             sub next {
1227 4887     4887 1 62649 my ($self) = @_;
1228              
1229 4887 100       8951 if (my $cache = $self->get_cache) {
1230 65   100     279 $self->{all_cache_position} ||= 0;
1231 65         1246 return $cache->[$self->{all_cache_position}++];
1232             }
1233              
1234 4822 100       10880 if ($self->{attrs}{cache}) {
1235 2         5 delete $self->{pager};
1236 2         5 $self->{all_cache_position} = 1;
1237 2         9 return ($self->all)[0];
1238             }
1239              
1240 4820 100       4639 return shift(@{$self->{_stashed_results}}) if @{ $self->{_stashed_results}||[] };
  11 100       38  
  4820         16358  
1241              
1242 4809 100       9863 $self->{_stashed_results} = $self->_construct_results
1243             or return undef;
1244              
1245 4069         3944 return shift @{$self->{_stashed_results}};
  4069         28046  
1246             }
1247              
1248             # Constructs as many results as it can in one pass while respecting
1249             # cursor laziness. Several modes of operation:
1250             #
1251             # * Always builds everything present in @{$self->{_stashed_rows}}
1252             # * If called with $fetch_all true - pulls everything off the cursor and
1253             # builds all result structures (or objects) in one pass
1254             # * If $self->_resolved_attrs->{collapse} is true, checks the order_by
1255             # and if the resultset is ordered properly by the left side:
1256             # * Fetches stuff off the cursor until the "master object" changes,
1257             # and saves the last extra row (if any) in @{$self->{_stashed_rows}}
1258             # OR
1259             # * Just fetches, and collapses/constructs everything as if $fetch_all
1260             # was requested (there is no other way to collapse except for an
1261             # eager cursor)
1262             # * If no collapse is requested - just get the next row, construct and
1263             # return
1264             sub _construct_results {
1265 8828     8828   10395 my ($self, $fetch_all) = @_;
1266              
1267 8828         15448 my $rsrc = $self->result_source;
1268 8828         16846 my $attrs = $self->_resolved_attrs;
1269              
1270 8827 100 100     41006 if (
      66        
      66        
1271             ! $fetch_all
1272             and
1273             ! $attrs->{order_by}
1274             and
1275             $attrs->{collapse}
1276             and
1277             my @pcols = $rsrc->primary_columns
1278             ) {
1279             # default order for collapsing unless the user asked for something
1280 35         65 $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} @pcols ];
  35         159  
1281 35         75 $attrs->{_ordered_for_collapse} = 1;
1282 35         57 $attrs->{_order_is_artificial} = 1;
1283             }
1284              
1285             # this will be used as both initial raw-row collector AND as a RV of
1286             # _construct_results. Not regrowing the array twice matters a lot...
1287             # a surprising amount actually
1288 8827         11927 my $rows = delete $self->{_stashed_rows};
1289              
1290 8827         8873 my $cursor; # we may not need one at all
1291              
1292 8827         10476 my $did_fetch_all = $fetch_all;
1293              
1294 8827 100       22643 if ($fetch_all) {
    100          
1295             # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
1296 1611 50       4769 $rows = [ ($rows ? @$rows : ()), $self->cursor->all ];
1297             }
1298             elsif( $attrs->{collapse} ) {
1299              
1300             # a cursor will need to be closed over in case of collapse
1301 109         295 $cursor = $self->cursor;
1302              
1303             $attrs->{_ordered_for_collapse} = (
1304             (
1305             $attrs->{order_by}
1306             and
1307             $rsrc->schema
1308             ->storage
1309             ->_extract_colinfo_of_stable_main_source_order_by_portion($attrs)
1310             ) ? 1 : 0
1311 109 100 66     465 ) unless defined $attrs->{_ordered_for_collapse};
    100          
1312              
1313 109 100       315 if (! $attrs->{_ordered_for_collapse}) {
1314 13         23 $did_fetch_all = 1;
1315              
1316             # instead of looping over ->next, use ->all in stealth mode
1317             # *without* calling a ->reset afterwards
1318             # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending
1319 13 100       43 if (! $cursor->{_done}) {
1320 8 50       63 $rows = [ ($rows ? @$rows : ()), $cursor->all ];
1321 7         35 $cursor->{_done} = 1;
1322             }
1323             }
1324             }
1325              
1326 8818 100 66     19225 if (! $did_fetch_all and ! @{$rows||[]} ) {
  7203 100       27432  
1327             # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
1328 4771   66     11945 $cursor ||= $self->cursor;
1329 4771 100       12103 if (scalar (my @r = $cursor->next) ) {
1330 4065         7421 $rows = [ \@r ];
1331             }
1332             }
1333              
1334 8811 100       11328 return undef unless @{$rows||[]};
  8811 100       30744  
1335              
1336             # sanity check - people are too clever for their own good
1337 7822 100 66     20583 if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) {
1338              
1339 226         284 my $multiplied_selectors;
1340 226         388 for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) {
  611         1359  
  226         808  
1341 423 100 66     1517 if (
1342             $aliastypes->{multiplying}{$sel_alias}
1343             or
1344             $aliastypes->{premultiplied}{$sel_alias}
1345             ) {
1346 341         381 $multiplied_selectors->{$_} = 1 for values %{$aliastypes->{selecting}{$sel_alias}{-seen_columns}}
  341         2223  
1347             }
1348             }
1349              
1350 226         413 for my $i (0 .. $#{$attrs->{as}} ) {
  226         706  
1351 2167         2075 my $sel = $attrs->{select}[$i];
1352              
1353 2167 100 66     5882 if (ref $sel eq 'SCALAR') {
    100          
1354 3         5 $sel = $$sel;
1355             }
1356             elsif( ref $sel eq 'REF' and ref $$sel eq 'ARRAY' ) {
1357 6         16 $sel = $$sel->[0];
1358             }
1359              
1360             $self->throw_exception(
1361             'Result collapse not possible - selection from a has_many source redirected to the main object'
1362 2167 100 100     6945 ) if ($multiplied_selectors->{$sel} and $attrs->{as}[$i] !~ /\./);
1363             }
1364             }
1365              
1366             # hotspot - skip the setter
1367 7786         16617 my $res_class = $self->_result_class;
1368              
1369 7786   66     26737 my $inflator_cref = $self->{_result_inflator}{cref} ||= do {
1370 4632 100       54270 $res_class->can ('inflate_result')
1371             or $self->throw_exception("Inflator $res_class does not provide an inflate_result() method");
1372             };
1373              
1374 7785         10445 my $infmap = $attrs->{as};
1375              
1376             $self->{_result_inflator}{is_core_row} = ( (
1377             $inflator_cref
1378             ==
1379             ( \&DBIx::Class::Row::inflate_result || die "No ::Row::inflate_result() - can't happen" )
1380 7785 100 50     34335 ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_core_row};
    100          
1381              
1382             $self->{_result_inflator}{is_hri} = ( (
1383             ! $self->{_result_inflator}{is_core_row}
1384             and
1385             $inflator_cref == (
1386             require DBIx::Class::ResultClass::HashRefInflator
1387             &&
1388             DBIx::Class::ResultClass::HashRefInflator->can('inflate_result')
1389             )
1390 7785 100 100     29741 ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_hri};
    100          
1391              
1392              
1393 7785 100       14632 if ($attrs->{_simple_passthrough_construction}) {
1394             # construct a much simpler array->hash folder for the one-table HRI cases right here
1395 7519 100 66     37485 if ($self->{_result_inflator}{is_hri}) {
    100          
1396 51         127 for my $r (@$rows) {
1397 142         218 $r = { map { $infmap->[$_] => $r->[$_] } 0..$#$infmap };
  317         654  
1398             }
1399             }
1400             # FIXME SUBOPTIMAL this is a very very very hot spot
1401             # while rather optimal we can *still* do much better, by
1402             # building a smarter Row::inflate_result(), and
1403             # switch to feeding it data via a much leaner interface
1404             #
1405             # crude unscientific benchmarking indicated the shortcut eval is not worth it for
1406             # this particular resultset size
1407             elsif ( $self->{_result_inflator}{is_core_row} and @$rows < 60 ) {
1408 7464         14049 for my $r (@$rows) {
1409 8707         17781 $r = $inflator_cref->($res_class, $rsrc, { map { $infmap->[$_] => $r->[$_] } (0..$#$infmap) } );
  51656         102779  
1410             }
1411             }
1412             else {
1413             eval sprintf (
1414             ( $self->{_result_inflator}{is_core_row}
1415             ? '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows'
1416             # a custom inflator may be a multiplier/reductor - put it in direct list ctx
1417             : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows'
1418             ),
1419 4 50       27 ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) )
  26 100       741  
1420             ) . '; 1' or die;
1421             }
1422             }
1423             else {
1424             my $parser_type =
1425             $self->{_result_inflator}{is_hri} ? 'hri'
1426 266 100       1307 : $self->{_result_inflator}{is_core_row} ? 'classic_pruning'
    100          
1427             : 'classic_nonpruning'
1428             ;
1429              
1430             # $args and $attrs to _mk_row_parser are separated to delineate what is
1431             # core collapser stuff and what is dbic $rs specific
1432 223         1282 @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({
1433             eval => 1,
1434             inflate_map => $infmap,
1435             collapse => $attrs->{collapse},
1436             premultiplied => $attrs->{_main_source_premultiplied},
1437             hri_style => $self->{_result_inflator}{is_hri},
1438             prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row},
1439 266 100 66     5309 }, $attrs) unless $self->{_row_parser}{$parser_type}{cref};
1440              
1441             # column_info metadata historically hasn't been too reliable.
1442             # We need to start fixing this somehow (the collapse resolver
1443             # can't work without it). Add an explicit check for the *main*
1444             # result, hopefully this will gradually weed out such errors
1445             #
1446             # FIXME - this is a temporary kludge that reduces performance
1447             # It is however necessary for the time being
1448 266         718 my ($unrolled_non_null_cols_to_check, $err);
1449              
1450 266 100       1141 if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) {
1451              
1452 168         364 $err =
1453             'Collapse aborted due to invalid ResultSource metadata - the following '
1454             . 'selections are declared non-nullable but NULLs were retrieved: '
1455             ;
1456              
1457 168         266 my @violating_idx;
1458 168         400 COL: for my $i (@$check_non_null_cols) {
1459 174   33     1903 ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows;
      50        
1460             }
1461              
1462 168 50       483 $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) )
  0         0  
1463             if @violating_idx;
1464              
1465 168         471 $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols);
1466              
1467 168         241 utf8::upgrade($unrolled_non_null_cols_to_check)
1468             if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE;
1469             }
1470              
1471             my $next_cref =
1472             ($did_fetch_all or ! $attrs->{collapse}) ? undef
1473             : defined $unrolled_non_null_cols_to_check ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check
1474             sub {
1475             # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
1476             my @r = $cursor->next or return;
1477             if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) {
1478             $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) )
1479             }
1480             \@r
1481             }
1482             EOS
1483             : sub {
1484             # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
1485 90 100   90   210 my @r = $cursor->next or return;
1486             \@r
1487 88         2113 }
1488 266 100 100     8449 ;
    100          
1489              
1490             $self->{_row_parser}{$parser_type}{cref}->(
1491             $rows,
1492 266 100       8354 $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (),
1493             );
1494              
1495             # simple in-place substitution, does not regrow $rows
1496 266 100       1234 if ($self->{_result_inflator}{is_core_row}) {
    100          
1497 200         1364 $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows
1498             }
1499             # Special-case multi-object HRI - there is no $inflator_cref pass at all
1500             elsif ( ! $self->{_result_inflator}{is_hri} ) {
1501             # the inflator may be a multiplier/reductor - put it in list ctx
1502 9         29 @$rows = map { $inflator_cref->($res_class, $rsrc, @$_) } @$rows;
  53         153  
1503             }
1504             }
1505              
1506             # The @$rows check seems odd at first - why wouldn't we want to warn
1507             # regardless? The issue is things like find() etc, where the user
1508             # *knows* only one result will come back. In these cases the ->all
1509             # is not a pessimization, but rather something we actually want
1510 7782 100 100     31065 carp_unique(
1511             'Unable to properly collapse has_many results in iterator mode due '
1512             . 'to order criteria - performed an eager cursor slurp underneath. '
1513             . 'Consider using ->all() instead'
1514             ) if ( ! $fetch_all and @$rows > 1 );
1515              
1516 7782         43634 return $rows;
1517             }
1518              
1519             =head2 result_source
1520              
1521             =over 4
1522              
1523             =item Arguments: L<$result_source?|DBIx::Class::ResultSource>
1524              
1525             =item Return Value: L<$result_source|DBIx::Class::ResultSource>
1526              
1527             =back
1528              
1529             An accessor for the primary ResultSource object from which this ResultSet
1530             is derived.
1531              
1532             =head2 result_class
1533              
1534             =over 4
1535              
1536             =item Arguments: $result_class?
1537              
1538             =item Return Value: $result_class
1539              
1540             =back
1541              
1542             An accessor for the class to use when creating result objects. Defaults to
1543             C<< result_source->result_class >> - which in most cases is the name of the
1544             L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class.
1545              
1546             Note that changing the result_class will also remove any components
1547             that were originally loaded in the source class via
1548             L.
1549             Any overloaded methods in the original source class will not run.
1550              
1551             =cut
1552              
1553             sub result_class {
1554 36955     36955 1 47356 my ($self, $result_class) = @_;
1555 36955 100       60848 if ($result_class) {
1556              
1557             # don't fire this for an object
1558 32949 50       113280 $self->ensure_class_loaded($result_class)
1559             unless ref($result_class);
1560              
1561 32945 100 66     322753 if ($self->get_cache) {
    100          
1562 1         5 carp_unique('Changing the result_class of a ResultSet instance with cached results is a noop - the cache contents will not be altered');
1563             }
1564             # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending
1565             elsif ($self->{cursor} && $self->{cursor}{_pos}) {
1566 1         4 $self->throw_exception('Changing the result_class of a ResultSet instance with an active cursor is not supported');
1567             }
1568              
1569 32944         86596 $self->_result_class($result_class);
1570              
1571 32944         102841 delete $self->{_result_inflator};
1572             }
1573 36950         93559 $self->_result_class;
1574             }
1575              
1576             =head2 count
1577              
1578             =over 4
1579              
1580             =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES>
1581              
1582             =item Return Value: $count
1583              
1584             =back
1585              
1586             Performs an SQL C with the same query as the resultset was built
1587             with to find the number of elements. Passing arguments is equivalent to
1588             C<< $rs->search ($cond, \%attrs)->count >>
1589              
1590             =cut
1591              
1592             sub count {
1593 621     621 1 64786 my $self = shift;
1594 621 100 100     2542 return $self->search(@_)->count if @_ and defined $_[0];
1595 606 100       1480 return scalar @{ $self->get_cache } if $self->get_cache;
  58         93  
1596              
1597 548         867 my $attrs = { %{ $self->_resolved_attrs } };
  548         1725  
1598              
1599             # this is a little optimization - it is faster to do the limit
1600             # adjustments in software, instead of a subquery
1601 548         1310 my ($rows, $offset) = delete @{$attrs}{qw/rows offset/};
  548         1338  
1602              
1603 548         710 my $crs;
1604 548 100       2517 if ($self->_has_resolved_attr (qw/collapse group_by/)) {
1605 65         282 $crs = $self->_count_subq_rs ($attrs);
1606             }
1607             else {
1608 483         1962 $crs = $self->_count_rs ($attrs);
1609             }
1610 548         2546 my $count = $crs->next;
1611              
1612 545 100       1424 $count -= $offset if $offset;
1613 545 100 100     1740 $count = $rows if $rows and $rows < $count;
1614 545 100       1342 $count = 0 if ($count < 0);
1615              
1616 545         2356 return $count;
1617             }
1618              
1619             =head2 count_rs
1620              
1621             =over 4
1622              
1623             =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES>
1624              
1625             =item Return Value: L<$count_rs|DBIx::Class::ResultSetColumn>
1626              
1627             =back
1628              
1629             Same as L but returns a L object.
1630             This can be very handy for subqueries:
1631              
1632             ->search( { amount => $some_rs->count_rs->as_query } )
1633              
1634             As with regular resultsets the SQL query will be executed only after
1635             the resultset is accessed via L or L. That would return
1636             the same single value obtainable via L.
1637              
1638             =cut
1639              
1640             sub count_rs {
1641 68     68 1 210 my $self = shift;
1642 68 100       247 return $self->search(@_)->count_rs if @_;
1643              
1644             # this may look like a lack of abstraction (count() does about the same)
1645             # but in fact an _rs *must* use a subquery for the limits, as the
1646             # software based limiting can not be ported if this $rs is to be used
1647             # in a subquery itself (i.e. ->as_query)
1648 58 100       281 if ($self->_has_resolved_attr (qw/collapse group_by offset rows/)) {
1649 28         124 return $self->_count_subq_rs($self->{_attrs});
1650             }
1651             else {
1652 30         196 return $self->_count_rs($self->{_attrs});
1653             }
1654             }
1655              
1656             #
1657             # returns a ResultSetColumn object tied to the count query
1658             #
1659             sub _count_rs {
1660 513     513   893 my ($self, $attrs) = @_;
1661              
1662 513         1330 my $rsrc = $self->result_source;
1663              
1664 513         3408 my $tmp_attrs = { %$attrs };
1665             # take off any limits, record_filter is cdbi, and no point of ordering nor locking a count
1666 513         1139 delete @{$tmp_attrs}{qw/rows offset order_by record_filter for/};
  513         1401  
1667              
1668             # overwrite the selector (supplied by the storage)
1669 513         13678 $rsrc->resultset_class->new($rsrc, {
1670             %$tmp_attrs,
1671             select => $rsrc->storage->_count_select ($rsrc, $attrs),
1672             as => 'count',
1673             })->get_column ('count');
1674             }
1675              
1676             #
1677             # same as above but uses a subquery
1678             #
1679             sub _count_subq_rs {
1680 93     93   140 my ($self, $attrs) = @_;
1681              
1682 93         238 my $rsrc = $self->result_source;
1683              
1684 93         610 my $sub_attrs = { %$attrs };
1685             # extra selectors do not go in the subquery and there is no point of ordering it, nor locking it
1686 93         195 delete @{$sub_attrs}{qw/collapse columns as select order_by for/};
  93         268  
1687              
1688             # if we multi-prefetch we group_by something unique, as this is what we would
1689             # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless
1690 93 100       257 if ( $attrs->{collapse} ) {
1691 31         222 $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{
1692 31 50       44 $rsrc->_identifying_column_set || $self->throw_exception(
  31         234  
1693             'Unable to construct a unique group_by criteria properly collapsing the '
1694             . 'has_many prefetch before count()'
1695             );
1696             } ]
1697             }
1698              
1699             # Calculate subquery selector
1700 93 100       255 if (my $g = $sub_attrs->{group_by}) {
1701              
1702 90         320 my $sql_maker = $rsrc->storage->sql_maker;
1703              
1704             # necessary as the group_by may refer to aliased functions
1705 90         134 my $sel_index;
1706 90         121 for my $sel (@{$attrs->{select}}) {
  90         222  
1707             $sel_index->{$sel->{-as}} = $sel
1708 544 100 100     1164 if (ref $sel eq 'HASH' and $sel->{-as});
1709             }
1710              
1711             # anything from the original select mentioned on the group-by needs to make it to the inner selector
1712             # also look for named aggregates referred in the having clause
1713             # having often contains scalarrefs - thus parse it out entirely
1714 90         220 my @parts = @$g;
1715 90 100       250 if ($attrs->{having}) {
1716 3         49 local $sql_maker->{having_bind};
1717 3         10 local $sql_maker->{quote_char} = $sql_maker->{quote_char};
1718 3         9 local $sql_maker->{name_sep} = $sql_maker->{name_sep};
1719 3 50 33     17 unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) {
1720 3         9 $sql_maker->{quote_char} = [ "\x00", "\xFF" ];
1721             # if we don't unset it we screw up retarded but unfortunately working
1722             # 'MAX(foo.bar)' => { '>', 3 }
1723 3         7 $sql_maker->{name_sep} = '';
1724             }
1725              
1726 3         20 my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
  9         23  
1727              
1728 3         29 my $having_sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} });
1729 3         9 my %seen_having;
1730              
1731             # search for both a proper quoted qualified string, for a naive unquoted scalarref
1732             # and if all fails for an utterly naive quoted scalar-with-function
1733 3         260 while ($having_sql =~ /
1734             $rquote $sep $lquote (.+?) $rquote
1735             |
1736             [\s,] \w+ \. (\w+) [\s,]
1737             |
1738             [\s,] $lquote (.+?) $rquote [\s,]
1739             /gx) {
1740 3   33     24 my $part = $1 || $2 || $3; # one of them matched if we got here
1741 3 100       25 unless ($seen_having{$part}++) {
1742 2         30 push @parts, $part;
1743             }
1744             }
1745             }
1746              
1747 90         161 for (@parts) {
1748 140   66     423 my $colpiece = $sel_index->{$_} || $_;
1749              
1750             # unqualify join-based group_by's. Arcane but possible query
1751             # also horrible horrible hack to alias a column (not a func.)
1752             # (probably need to introduce SQLA syntax)
1753 140 100 100     1163 if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) {
1754 3         5 my $as = $colpiece;
1755 3         10 $as =~ s/\./__/;
1756 3         5 $colpiece = \ sprintf ('%s AS %s', map { $sql_maker->_quote ($_) } ($colpiece, $as) );
  6         59  
1757             }
1758 140         180 push @{$sub_attrs->{select}}, $colpiece;
  140         436  
1759             }
1760             }
1761             else {
1762 3         31 my @pcols = map { "$attrs->{alias}.$_" } ($rsrc->primary_columns);
  3         13  
1763 3 50       11 $sub_attrs->{select} = @pcols ? \@pcols : [ 1 ];
1764             }
1765              
1766 93         1960 return $rsrc->resultset_class
1767             ->new ($rsrc, $sub_attrs)
1768             ->as_subselect_rs
1769             ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } })
1770             ->get_column ('count');
1771             }
1772              
1773              
1774             =head2 count_literal
1775              
1776             B: C is provided for Class::DBI compatibility and
1777             should only be used in that context. See L for further info.
1778              
1779             =over 4
1780              
1781             =item Arguments: $sql_fragment, @standalone_bind_values
1782              
1783             =item Return Value: $count
1784              
1785             =back
1786              
1787             Counts the results in a literal query. Equivalent to calling L
1788             with the passed arguments, then L.
1789              
1790             =cut
1791              
1792 0     0 1 0 sub count_literal { shift->search_literal(@_)->count; }
1793              
1794             =head2 all
1795              
1796             =over 4
1797              
1798             =item Arguments: none
1799              
1800             =item Return Value: L<@result_objs|DBIx::Class::Manual::ResultClass>
1801              
1802             =back
1803              
1804             Returns all elements in the resultset.
1805              
1806             =cut
1807              
1808             sub all {
1809 1677     1677 1 245662 my $self = shift;
1810 1677 50       4771 if(@_) {
1811 0         0 $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
1812             }
1813              
1814 1677         2659 delete @{$self}{qw/_stashed_rows _stashed_results/};
  1677         4188  
1815              
1816 1677 100       3843 if (my $c = $self->get_cache) {
1817 66         317 return @$c;
1818             }
1819              
1820 1611         4345 $self->cursor->reset;
1821              
1822 1611   100     4743 my $objs = $self->_construct_results('fetch_all') || [];
1823              
1824 1590 100       5191 $self->set_cache($objs) if $self->{attrs}{cache};
1825              
1826 1590         7809 return @$objs;
1827             }
1828              
1829             =head2 reset
1830              
1831             =over 4
1832              
1833             =item Arguments: none
1834              
1835             =item Return Value: $self
1836              
1837             =back
1838              
1839             Resets the resultset's cursor, so you can iterate through the elements again.
1840             Implicitly resets the storage cursor, so a subsequent L will trigger
1841             another query.
1842              
1843             =cut
1844              
1845             sub reset {
1846 1523     1523 1 2463 my ($self) = @_;
1847              
1848 1523         2336 delete @{$self}{qw/_stashed_rows _stashed_results/};
  1523         3465  
1849 1523         3126 $self->{all_cache_position} = 0;
1850 1523         4167 $self->cursor->reset;
1851 1523         4126 return $self;
1852             }
1853              
1854             =head2 first
1855              
1856             =over 4
1857              
1858             =item Arguments: none
1859              
1860             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef
1861              
1862             =back
1863              
1864             L the resultset (causing a fresh query to storage) and returns
1865             an object for the first result (or C if the resultset is empty).
1866              
1867             =cut
1868              
1869             sub first {
1870 884     884 1 82303 return $_[0]->reset->next;
1871             }
1872              
1873              
1874             # _rs_update_delete
1875             #
1876             # Determines whether and what type of subquery is required for the $rs operation.
1877             # If grouping is necessary either supplies its own, or verifies the current one
1878             # After all is done delegates to the proper storage method.
1879              
1880             sub _rs_update_delete {
1881 602     602   967 my ($self, $op, $values) = @_;
1882              
1883 602         1627 my $rsrc = $self->result_source;
1884 602         2588 my $storage = $rsrc->schema->storage;
1885              
1886 602         6410 my $attrs = { %{$self->_resolved_attrs} };
  602         1892  
1887              
1888 602         1390 my $join_classifications;
1889 602         857 my ($existing_group_by) = delete @{$attrs}{qw(group_by _grouped_by_distinct)};
  602         1501  
1890              
1891             # do we need a subquery for any reason?
1892             my $needs_subq = (
1893             defined $existing_group_by
1894             or
1895             # if {from} is unparseable wrap a subq
1896 602   100     5182 ref($attrs->{from}) ne 'ARRAY'
1897             or
1898             # limits call for a subq
1899             $self->_has_resolved_attr(qw/rows offset/)
1900             );
1901              
1902             # simplify the joinmap, so we can further decide if a subq is necessary
1903 602 100 100     2268 if (!$needs_subq and @{$attrs->{from}} > 1) {
  597         2288  
1904              
1905 19         171 ($attrs->{from}, $join_classifications) =
1906             $storage->_prune_unused_joins ($attrs);
1907              
1908             # any non-pruneable non-local restricting joins imply subq
1909 19 50   25   92 $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} };
  25         56  
  19         107  
1910             }
1911              
1912             # check if the head is composite (by now all joins are thrown out unless $needs_subq)
1913             $needs_subq ||= (
1914             (ref $attrs->{from}[0]) ne 'HASH'
1915             or
1916             ref $attrs->{from}[0]{ $attrs->{from}[0]{-alias} }
1917 602   66     5416 );
      100        
1918              
1919 602         646 my ($cond, $guard);
1920             # do we need anything like a subquery?
1921 602 100       1259 if (! $needs_subq) {
1922             # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
1923             # a condition containing 'me' or other table prefixes will not work
1924             # at all. Tell SQLMaker to dequalify idents via a gross hack.
1925 571         545 $cond = do {
1926 571         2182 my $sqla = $rsrc->storage->sql_maker;
1927 571         1711 local $sqla->{_dequalify_idents} = 1;
1928 571         2439 \[ $sqla->_recurse_where($self->{cond}) ];
1929             };
1930             }
1931             else {
1932             # we got this far - means it is time to wrap a subquery
1933 31   33     236 my $idcols = $rsrc->_identifying_column_set || $self->throw_exception(
1934             sprintf(
1935             "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'",
1936             $op,
1937             $rsrc->source_name,
1938             )
1939             );
1940              
1941             # make a new $rs selecting only the PKs (that's all we really need for the subq)
1942 31         138 delete $attrs->{$_} for qw/select as collapse/;
1943 31         72 $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ];
  66         183  
1944              
1945             # this will be consumed by the pruner waaaaay down the stack
1946 31         84 $attrs->{_force_prune_multiplying_joins} = 1;
1947              
1948 31         140 my $subrs = (ref $self)->new($rsrc, $attrs);
1949              
1950 31 100       357 if (@$idcols == 1) {
    100          
1951 20         142 $cond = { $idcols->[0] => { -in => $subrs->as_query } };
1952             }
1953             elsif ($storage->_use_multicolumn_in) {
1954             # no syntax for calling this properly yet
1955             # !!! EXPERIMENTAL API !!! WILL CHANGE !!!
1956 1         17 $cond = $storage->sql_maker->_where_op_multicolumn_in (
1957             $idcols, # how do I convey a list of idents...? can binds reside on lhs?
1958             $subrs->as_query
1959             ),
1960             }
1961             else {
1962             # if all else fails - get all primary keys and operate over a ORed set
1963             # wrap in a transaction for consistency
1964             # this is where the group_by/multiplication starts to matter
1965 10 100 100     29 if (
1966             $existing_group_by
1967             or
1968             # we do not need to check pre-multipliers, since if the premulti is there, its
1969             # parent (who is multi) will be there too
1970 8 100       60 keys %{ $join_classifications->{multiplying} || {} }
1971             ) {
1972             # make sure if there is a supplied group_by it matches the columns compiled above
1973             # perfectly. Anything else can not be sanely executed on most databases so croak
1974             # right then and there
1975 5 100       13 if ($existing_group_by) {
1976             my @current_group_by = map
1977 2 100       4 { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
  14         28  
1978             @$existing_group_by
1979             ;
1980              
1981 2 100       13 if (
1982             join ("\x00", sort @current_group_by)
1983             ne
1984 2         14 join ("\x00", sort @{$attrs->{columns}} )
1985             ) {
1986 1         20 $self->throw_exception (
1987             "You have just attempted a $op operation on a resultset which does group_by"
1988             . ' on columns other than the primary keys, while DBIC internally needs to retrieve'
1989             . ' the primary keys in a subselect. All sane RDBMS engines do not support this'
1990             . ' kind of queries. Please retry the operation with a modified group_by or'
1991             . ' without using one at all.'
1992             );
1993             }
1994             }
1995              
1996 4         17 $subrs = $subrs->search({}, { group_by => $attrs->{columns} });
1997             }
1998              
1999 9         61 $guard = $storage->txn_scope_guard;
2000              
2001 9         38 for my $row ($subrs->cursor->all) {
2002             push @$cond, { map
2003 19         44 { $idcols->[$_] => $row->[$_] }
  66         146  
2004             (0 .. $#$idcols)
2005             };
2006             }
2007             }
2008             }
2009              
2010 601 100       103812 my $res = $cond ? $storage->$op (
    100          
2011             $rsrc,
2012             $op eq 'update' ? $values : (),
2013             $cond,
2014             ) : '0E0';
2015              
2016 596 100       3842 $guard->commit if $guard;
2017              
2018 596         4833 return $res;
2019             }
2020              
2021             =head2 update
2022              
2023             =over 4
2024              
2025             =item Arguments: \%values
2026              
2027             =item Return Value: $underlying_storage_rv
2028              
2029             =back
2030              
2031             Sets the specified columns in the resultset to the supplied values in a
2032             single query. Note that this will not run any accessor/set_column/update
2033             triggers, nor will it update any result object instances derived from this
2034             resultset (this includes the contents of the L
2035             if any). See L if you need to execute any on-update
2036             triggers or cascades defined either by you or a
2037             L.
2038              
2039             The return value is a pass through of what the underlying
2040             storage backend returned, and may vary. See L for the most
2041             common case.
2042              
2043             =head3 CAVEAT
2044              
2045             Note that L does not process/deflate any of the values passed in.
2046             This is unlike the corresponding L. The user must
2047             ensure manually that any value passed to this method will stringify to
2048             something the RDBMS knows how to deal with. A notable example is the
2049             handling of L objects, for more info see:
2050             L.
2051              
2052             =cut
2053              
2054             sub update {
2055 496     496 1 4354 my ($self, $values) = @_;
2056 496 50       1478 $self->throw_exception('Values for update must be a hash')
2057             unless ref $values eq 'HASH';
2058              
2059 496         1841 return $self->_rs_update_delete ('update', $values);
2060             }
2061              
2062             =head2 update_all
2063              
2064             =over 4
2065              
2066             =item Arguments: \%values
2067              
2068             =item Return Value: 1
2069              
2070             =back
2071              
2072             Fetches all objects and updates them one at a time via
2073             L. Note that C will run DBIC defined
2074             triggers, while L will not.
2075              
2076             =cut
2077              
2078             sub update_all {
2079 1     1 1 712 my ($self, $values) = @_;
2080 1 50       5 $self->throw_exception('Values for update_all must be a hash')
2081             unless ref $values eq 'HASH';
2082              
2083 1         6 my $guard = $self->result_source->schema->txn_scope_guard;
2084 1         7 $_->update({%$values}) for $self->all; # shallow copy - update will mangle it
2085 1         13 $guard->commit;
2086 1         2 return 1;
2087             }
2088              
2089             =head2 delete
2090              
2091             =over 4
2092              
2093             =item Arguments: none
2094              
2095             =item Return Value: $underlying_storage_rv
2096              
2097             =back
2098              
2099             Deletes the rows matching this resultset in a single query. Note that this
2100             will not run any delete triggers, nor will it alter the
2101             L status of any result object instances
2102             derived from this resultset (this includes the contents of the
2103             L if any). See L if you need to
2104             execute any on-delete triggers or cascades defined either by you or a
2105             L.
2106              
2107             The return value is a pass through of what the underlying storage backend
2108             returned, and may vary. See L for the most common case.
2109              
2110             =cut
2111              
2112             sub delete {
2113 106     106 1 3133 my $self = shift;
2114 106 50       334 $self->throw_exception('delete does not accept any arguments')
2115             if @_;
2116              
2117 106         378 return $self->_rs_update_delete ('delete');
2118             }
2119              
2120             =head2 delete_all
2121              
2122             =over 4
2123              
2124             =item Arguments: none
2125              
2126             =item Return Value: 1
2127              
2128             =back
2129              
2130             Fetches all objects and deletes them one at a time via
2131             L. Note that C will run DBIC defined
2132             triggers, while L will not.
2133              
2134             =cut
2135              
2136             sub delete_all {
2137 270     270 1 558 my $self = shift;
2138 270 50       611 $self->throw_exception('delete_all does not accept any arguments')
2139             if @_;
2140              
2141 270         1115 my $guard = $self->result_source->schema->txn_scope_guard;
2142 270         821 $_->delete for $self->all;
2143 270         1107 $guard->commit;
2144 270         1088 return 1;
2145             }
2146              
2147             =head2 populate
2148              
2149             =over 4
2150              
2151             =item Arguments: [ \@column_list, \@row_values+ ] | [ \%col_data+ ]
2152              
2153             =item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context)
2154              
2155             =back
2156              
2157             Accepts either an arrayref of hashrefs or alternatively an arrayref of
2158             arrayrefs.
2159              
2160             =over
2161              
2162             =item NOTE
2163              
2164             The context of this method call has an important effect on what is
2165             submitted to storage. In void context data is fed directly to fastpath
2166             insertion routines provided by the underlying storage (most often
2167             L), bypassing the L and
2168             L calls on the
2169             L class, including any
2170             augmentation of these methods provided by components. For example if you
2171             are using something like L to create primary
2172             keys for you, you will find that your PKs are empty. In this case you
2173             will have to explicitly force scalar or list context in order to create
2174             those values.
2175              
2176             =back
2177              
2178             In non-void (scalar or list) context, this method is simply a wrapper
2179             for L. Depending on list or scalar context either a list of
2180             L objects or an arrayref
2181             containing these objects is returned.
2182              
2183             When supplying data in "arrayref of arrayrefs" invocation style, the
2184             first element should be a list of column names and each subsequent
2185             element should be a data value in the earlier specified column order.
2186             For example:
2187              
2188             $schema->resultset("Artist")->populate([
2189             [ qw( artistid name ) ],
2190             [ 100, 'A Formally Unknown Singer' ],
2191             [ 101, 'A singer that jumped the shark two albums ago' ],
2192             [ 102, 'An actually cool singer' ],
2193             ]);
2194              
2195             For the arrayref of hashrefs style each hashref should be a structure
2196             suitable for passing to L. Multi-create is also permitted with
2197             this syntax.
2198              
2199             $schema->resultset("Artist")->populate([
2200             { artistid => 4, name => 'Manufactured Crap', cds => [
2201             { title => 'My First CD', year => 2006 },
2202             { title => 'Yet More Tweeny-Pop crap', year => 2007 },
2203             ],
2204             },
2205             { artistid => 5, name => 'Angsty-Whiny Girl', cds => [
2206             { title => 'My parents sold me to a record company', year => 2005 },
2207             { title => 'Why Am I So Ugly?', year => 2006 },
2208             { title => 'I Got Surgery and am now Popular', year => 2007 }
2209             ],
2210             },
2211             ]);
2212              
2213             If you attempt a void-context multi-create as in the example above (each
2214             Artist also has the related list of CDs), and B supply the
2215             necessary autoinc foreign key information, this method will proxy to the
2216             less efficient L, and then throw the Result objects away. In this
2217             case there are obviously no benefits to using this method over L.
2218              
2219             =cut
2220              
2221             sub populate {
2222 7705     7705 1 14279 my $self = shift;
2223              
2224             # this is naive and just a quick check
2225             # the types will need to be checked more thoroughly when the
2226             # multi-source populate gets added
2227             my $data = (
2228             ref $_[0] eq 'ARRAY'
2229             and
2230 7705 50 33     20951 ( @{$_[0]} or return )
2231             and
2232             ( ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY' )
2233             and
2234             $_[0]
2235             ) or $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs');
2236              
2237             # FIXME - no cref handling
2238             # At this point assume either hashes or arrays
2239              
2240 7698 100       13532 if(defined wantarray) {
2241 41         82 my (@results, $guard);
2242              
2243 41 100       145 if (ref $data->[0] eq 'ARRAY') {
2244             # column names only, nothing to do
2245 21 100       64 return if @$data == 1;
2246              
2247 17 100       92 $guard = $self->result_source->schema->storage->txn_scope_guard
2248             if @$data > 2;
2249              
2250             @results = map
2251 46         67 { my $vals = $_; $self->new_result({ map { $data->[0][$_] => $vals->[$_] } 0..$#{$data->[0]} })->insert }
  46         63  
  108         345  
  46         86  
2252 17         44 @{$data}[1 .. $#$data]
  17         39  
2253             ;
2254             }
2255             else {
2256              
2257 20 100       128 $guard = $self->result_source->schema->storage->txn_scope_guard
2258             if @$data > 1;
2259              
2260 20         60 @results = map { $self->new_result($_)->insert } @$data;
  56         219  
2261             }
2262              
2263 37 100       203 $guard->commit if $guard;
2264 37 100       252 return wantarray ? @results : \@results;
2265             }
2266              
2267             # we have to deal with *possibly incomplete* related data
2268             # this means we have to walk the data structure twice
2269             # whether we want this or not
2270             # jnap, I hate you ;)
2271 7657         12461 my $rsrc = $self->result_source;
2272 7657         47008 my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships };
  21457         33605  
2273              
2274 7657         9582 my ($colinfo, $colnames, $slices_with_rels);
2275 7657         7577 my $data_start = 0;
2276              
2277             DATA_SLICE:
2278 7657         16966 for my $i (0 .. $#$data) {
2279              
2280 44501         30671 my $current_slice_seen_rel_infos;
2281              
2282             ### Determine/Supplement collists
2283             ### BEWARE - This is a hot piece of code, a lot of weird idioms were used
2284 44501 100       58735 if( ref $data->[$i] eq 'ARRAY' ) {
    50          
2285              
2286             # positional(!) explicit column list
2287 44395 100       45214 if ($i == 0) {
2288             # column names only, nothing to do
2289 7613 100       14682 return if @$data == 1;
2290              
2291             $colinfo->{$data->[0][$_]} = { pos => $_, name => $data->[0][$_] } and push @$colnames, $data->[0][$_]
2292 7611   33     6712 for 0 .. $#{$data->[0]};
  7611         81447  
2293              
2294 7611         8531 $data_start = 1;
2295              
2296 7611         12727 next DATA_SLICE;
2297             }
2298             else {
2299 36782         45899 for (values %$colinfo) {
2300 102956 100 100     468901 if ($_->{is_rel} ||= (
      100        
2301             $rel_info->{$_->{name}}
2302             and
2303             (
2304             ref $data->[$i][$_->{pos}] eq 'ARRAY'
2305             or
2306             ref $data->[$i][$_->{pos}] eq 'HASH'
2307             or
2308             ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') )
2309             )
2310             and
2311             1
2312             )) {
2313              
2314             # moar sanity check... sigh
2315 4 50       11 for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) {
  4         9  
2316 5 50 33     21 if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) {
2317 0         0 carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()");
2318 0         0 return my $throwaway = $self->populate(@_);
2319             }
2320             }
2321              
2322 4         13 push @$current_slice_seen_rel_infos, $rel_info->{$_->{name}};
2323             }
2324             }
2325             }
2326              
2327 36782 100       45719 if ($current_slice_seen_rel_infos) {
2328 4         11 push @$slices_with_rels, { map { $colnames->[$_] => $data->[$i][$_] } 0 .. $#$colnames };
  8         23  
2329              
2330             # this is needed further down to decide whether or not to fallback to create()
2331             $colinfo->{$colnames->[$_]}{seen_null} ||= ! defined $data->[$i][$_]
2332 4   66     38 for 0 .. $#$colnames;
2333             }
2334             }
2335             elsif( ref $data->[$i] eq 'HASH' ) {
2336              
2337 106         107 for ( sort keys %{$data->[$i]} ) {
  106         311  
2338              
2339 224   66     411 $colinfo->{$_} ||= do {
2340              
2341 97 50       172 $self->throw_exception("Column '$_' must be present in supplied explicit column list")
2342             if $data_start; # it will be 0 on AoH, 1 on AoA
2343              
2344 97         142 push @$colnames, $_;
2345              
2346             # RV
2347 97         327 { pos => $#$colnames, name => $_ }
2348             };
2349              
2350 224 100 100     2678 if ($colinfo->{$_}{is_rel} ||= (
      100        
2351             $rel_info->{$_}
2352             and
2353             (
2354             ref $data->[$i]{$_} eq 'ARRAY'
2355             or
2356             ref $data->[$i]{$_} eq 'HASH'
2357             or
2358             ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') )
2359             )
2360             and
2361             1
2362             )) {
2363              
2364             # moar sanity check... sigh
2365 12 100       34 for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) {
  10         23  
2366 18 100 66     59 if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) {
2367 1         4 carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()");
2368 1         84 return my $throwaway = $self->populate(@_);
2369             }
2370             }
2371              
2372 11         23 push @$current_slice_seen_rel_infos, $rel_info->{$_};
2373             }
2374             }
2375              
2376 105 100       188 if ($current_slice_seen_rel_infos) {
2377 11         17 push @$slices_with_rels, $data->[$i];
2378              
2379             # this is needed further down to decide whether or not to fallback to create()
2380             $colinfo->{$_}{seen_null} ||= ! defined $data->[$i]{$_}
2381 11   66     15 for keys %{$data->[$i]};
  11         109  
2382             }
2383             }
2384             else {
2385 0         0 $self->throw_exception('Unexpected populate() data structure member type: ' . ref $data->[$i] );
2386             }
2387              
2388 36887 100       24373 if ( grep
2389 15         60 { $_->{attrs}{is_depends_on} }
2390 36887 100       129183 @{ $current_slice_seen_rel_infos || [] }
2391             ) {
2392 2         11 carp_unique("Fast-path populate() of belongs_to relationship data is not possible - falling back to regular create()");
2393 2         214 return my $throwaway = $self->populate(@_);
2394             }
2395             }
2396              
2397 7652 100       12934 if( $slices_with_rels ) {
2398              
2399             # need to exclude the rel "columns"
2400 5         9 $colnames = [ grep { ! $colinfo->{$_}{is_rel} } @$colnames ];
  15         32  
2401              
2402             # extra sanity check - ensure the main source is in fact identifiable
2403             # the localizing of nullability is insane, but oh well... the use-case is legit
2404 5         24 my $ci = $rsrc->columns_info($colnames);
2405              
2406 8         39 $ci->{$_} = { %{$ci->{$_}}, is_nullable => 0 }
2407 5         18 for grep { ! $colinfo->{$_}{seen_null} } keys %$ci;
  10         25  
2408              
2409 5 100       35 unless( $rsrc->_identifying_column_set($ci) ) {
2410 1         7 carp_unique("Fast-path populate() of non-uniquely identifiable rows with related data is not possible - falling back to regular create()");
2411 1         148 return my $throwaway = $self->populate(@_);
2412             }
2413             }
2414              
2415             ### inherit the data locked in the conditions of the resultset
2416 7651         17582 my ($rs_data) = $self->_merge_with_rscond({});
2417 7651         10066 delete @{$rs_data}{@$colnames}; # passed-in stuff takes precedence
  7651         11211  
2418              
2419             # if anything left - decompose rs_data
2420 7651         6481 my $rs_data_vals;
2421 7651 100       15293 if (keys %$rs_data) {
2422             push @$rs_data_vals, $rs_data->{$_}
2423 9         43 for sort keys %$rs_data;
2424             }
2425              
2426             ### start work
2427 7651         7033 my $guard;
2428 7651 100       11202 $guard = $rsrc->schema->storage->txn_scope_guard
2429             if $slices_with_rels;
2430              
2431             ### main source data
2432             # FIXME - need to switch entirely to a coderef-based thing,
2433             # so that large sets aren't copied several times... I think
2434             $rsrc->storage->_insert_bulk(
2435             $rsrc,
2436             [ @$colnames, sort keys %$rs_data ],
2437             [ map {
2438 7651         20159 ref $data->[$_] eq 'ARRAY'
2439             ? (
2440 0 0       0 $slices_with_rels ? [ @{$data->[$_]}[0..$#$colnames], @{$rs_data_vals||[]} ] # the collist changed
  0         0  
2441 0         0 : $rs_data_vals ? [ @{$data->[$_]}, @$rs_data_vals ]
2442             : $data->[$_]
2443             )
2444 36881 50       292852 : [ @{$data->[$_]}{@$colnames}, @{$rs_data_vals||[]} ]
  103 50       129  
  103 100       1043  
    100          
2445             } $data_start .. $#$data ],
2446             );
2447              
2448             ### do the children relationships
2449 7644 100       24165 if ( $slices_with_rels ) {
2450 4 50       14 my @rels = grep { $colinfo->{$_}{is_rel} } keys %$colinfo
  13         32  
2451             or die 'wtf... please report a bug with DBIC_TRACE=1 output (stacktrace)';
2452              
2453 4         11 for my $sl (@$slices_with_rels) {
2454              
2455 9         12 my ($main_proto, $main_proto_rs);
2456 9         18 for my $rel (@rels) {
2457 9 50       25 next unless defined $sl->{$rel};
2458              
2459             $main_proto ||= {
2460             %$rs_data,
2461 9   50     41 (map { $_ => $sl->{$_} } @$colnames),
  17         56  
2462             };
2463              
2464 9 100       29 unless (defined $colinfo->{$rel}{rs}) {
2465              
2466 4         21 $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset;
2467              
2468 4         27 $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition(
2469             rel_name => $rel,
2470             self_alias => "\xFE", # irrelevant
2471             foreign_alias => "\xFF", # irrelevant
2472 4 50       23 )->{identity_map} || {} } };
2473              
2474             }
2475              
2476             $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search
2477             {
2478             $_ => { '=' =>
2479             ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) )
2480 10   66     61 ->get_column( $colinfo->{$rel}{fk_map}{$_} )
2481             ->as_query
2482             }
2483             }
2484 9         27 keys %{$colinfo->{$rel}{fk_map}}
2485 9 50       22 })->populate( ref $sl->{$rel} eq 'ARRAY' ? $sl->{$rel} : [ $sl->{$rel} ] );
2486              
2487 9         33 1;
2488             }
2489             }
2490             }
2491              
2492 7644 100       59365 $guard->commit if $guard;
2493             }
2494              
2495             =head2 pager
2496              
2497             =over 4
2498              
2499             =item Arguments: none
2500              
2501             =item Return Value: L<$pager|Data::Page>
2502              
2503             =back
2504              
2505             Returns a L object for the current resultset. Only makes
2506             sense for queries with a C attribute.
2507              
2508             To get the full count of entries for a paged resultset, call
2509             C on the L object.
2510              
2511             =cut
2512              
2513             sub pager {
2514 28     28 1 4937 my ($self) = @_;
2515              
2516 28 100       103 return $self->{pager} if $self->{pager};
2517              
2518 16         22 my $attrs = $self->{attrs};
2519 16 50       54 if (!defined $attrs->{page}) {
    50          
2520 0         0 $self->throw_exception("Can't create pager for non-paged rs");
2521             }
2522             elsif ($attrs->{page} <= 0) {
2523 0         0 $self->throw_exception('Invalid page number (page-numbers are 1-based)');
2524             }
2525 16   50     29 $attrs->{rows} ||= 10;
2526              
2527             # throw away the paging flags and re-run the count (possibly
2528             # with a subselect) to get the real total count
2529 16         63 my $count_attrs = { %$attrs };
2530 16         29 delete @{$count_attrs}{qw/rows offset page pager/};
  16         35  
2531              
2532 16         55 my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
2533              
2534 16         1649 require DBIx::Class::ResultSet::Pager;
2535             return $self->{pager} = DBIx::Class::ResultSet::Pager->new(
2536 10     10   27 sub { $total_rs->count }, #lazy-get the total
2537             $attrs->{rows},
2538             $self->{attrs}{page},
2539 16         144 );
2540             }
2541              
2542             =head2 page
2543              
2544             =over 4
2545              
2546             =item Arguments: $page_number
2547              
2548             =item Return Value: L<$resultset|/search>
2549              
2550             =back
2551              
2552             Returns a resultset for the $page_number page of the resultset on which page
2553             is called, where each page contains a number of rows equal to the 'rows'
2554             attribute set on the resultset (10 by default).
2555              
2556             =cut
2557              
2558             sub page {
2559 12     12 1 728 my ($self, $page) = @_;
2560 12         30 return (ref $self)->new($self->result_source, { %{$self->{attrs}}, page => $page });
  12         64  
2561             }
2562              
2563             =head2 new_result
2564              
2565             =over 4
2566              
2567             =item Arguments: \%col_data
2568              
2569             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
2570              
2571             =back
2572              
2573             Creates a new result object in the resultset's result class and returns
2574             it. The row is not inserted into the database at this point, call
2575             L to do that. Calling L
2576             will tell you whether the result object has been inserted or not.
2577              
2578             Passes the hashref of input on to L.
2579              
2580             =cut
2581              
2582             sub new_result {
2583 1492     1492 1 2070 my ($self, $values) = @_;
2584              
2585 1492 50       3898 $self->throw_exception( "new_result takes only one argument - a hashref of values" )
2586             if @_ > 2;
2587              
2588 1492 50       3900 $self->throw_exception( "Result object instantiation requires a hashref as argument" )
2589             unless (ref $values eq 'HASH');
2590              
2591 1492         3561 my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values);
2592              
2593 1492 100       3994 my $new = $self->result_class->new({
2594             %$merged_cond,
2595             ( @$cols_from_relations
2596             ? (-cols_from_relations => $cols_from_relations)
2597             : ()
2598             ),
2599             -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
2600             });
2601              
2602 1490 50 33     12395 if (
      33        
2603             reftype($new) eq 'HASH'
2604             and
2605             ! keys %$new
2606             and
2607             blessed($new)
2608             ) {
2609 0         0 carp_unique (sprintf (
2610             "%s->new returned a blessed empty hashref - a strong indicator something is wrong with its inheritance chain",
2611             $self->result_class,
2612             ));
2613             }
2614              
2615 1490         11586 $new;
2616             }
2617              
2618             # _merge_with_rscond
2619             #
2620             # Takes a simple hash of K/V data and returns its copy merged with the
2621             # condition already present on the resultset. Additionally returns an
2622             # arrayref of value/condition names, which were inferred from related
2623             # objects (this is needed for in-memory related objects)
2624             sub _merge_with_rscond {
2625 12357     12357   14948 my ($self, $data) = @_;
2626              
2627 12357         10727 my ($implied_data, @cols_from_relations);
2628              
2629 12357         31849 my $alias = $self->{attrs}{alias};
2630              
2631 12357 100       27649 if (! defined $self->{cond}) {
    100          
2632             # just massage $data below
2633             }
2634             elsif ($self->{cond} eq UNRESOLVABLE_CONDITION) {
2635 6         13 $implied_data = $self->{attrs}{related_objects}; # nothing might have been inserted yet
2636 6 50       8 @cols_from_relations = keys %{ $implied_data || {} };
  6         35  
2637             }
2638             else {
2639 2061         8566 my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls');
2640             $implied_data = { map {
2641 2061 50 100     4770 ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} )
  2107         13212  
2642             } keys %$eqs };
2643             }
2644              
2645             return (
2646             { map
2647 12357   100     49841 { %{ $self->_remove_alias($_, $alias) } }
  14424         11175  
  14424         25862  
2648             # precedence must be given to passed values over values inherited from
2649             # the cond, so the order here is important.
2650             ( $implied_data||(), $data)
2651             },
2652             \@cols_from_relations
2653             );
2654             }
2655              
2656             # _has_resolved_attr
2657             #
2658             # determines if the resultset defines at least one
2659             # of the attributes supplied
2660             #
2661             # used to determine if a subquery is necessary
2662             #
2663             # supports some virtual attributes:
2664             # -join
2665             # This will scan for any joins being present on the resultset.
2666             # It is not a mere key-search but a deep inspection of {from}
2667             #
2668              
2669             sub _has_resolved_attr {
2670 1422     1422   3411 my ($self, @attr_names) = @_;
2671              
2672 1422         3602 my $attrs = $self->_resolved_attrs;
2673              
2674 1422         1919 my %extra_checks;
2675              
2676 1422         2878 for my $n (@attr_names) {
2677 3294 50       3585 if (grep { $n eq $_ } (qw/-join/) ) {
  3294         8465  
2678 0         0 $extra_checks{$n}++;
2679 0         0 next;
2680             }
2681              
2682 3294         3903 my $attr = $attrs->{$n};
2683              
2684 3294 100       6453 next if not defined $attr;
2685              
2686 125 50       498 if (ref $attr eq 'HASH') {
    100          
2687 0 0       0 return 1 if keys %$attr;
2688             }
2689             elsif (ref $attr eq 'ARRAY') {
2690 64 50       278 return 1 if @$attr;
2691             }
2692             else {
2693 61 100       298 return 1 if $attr;
2694             }
2695             }
2696              
2697             # a resolved join is expressed as a multi-level from
2698             return 1 if (
2699             $extra_checks{-join}
2700             and
2701             ref $attrs->{from} eq 'ARRAY'
2702             and
2703 1317 0 33     4991 @{$attrs->{from}} > 1
  0   33     0  
2704             );
2705              
2706 1317         5044 return 0;
2707             }
2708              
2709             # _remove_alias
2710             #
2711             # Remove the specified alias from the specified query hash. A copy is made so
2712             # the original query is not modified.
2713              
2714             sub _remove_alias {
2715 14424     14424   16700 my ($self, $query, $alias) = @_;
2716              
2717 14424 50       12097 my %orig = %{ $query || {} };
  14424         47585  
2718 14424         14591 my %unaliased;
2719              
2720 14424         23096 foreach my $key (keys %orig) {
2721 8299 100       19912 if ($key !~ /\./) {
2722 6644         9850 $unaliased{$key} = $orig{$key};
2723 6644         8058 next;
2724             }
2725 1655 100       18283 $unaliased{$1} = $orig{$key}
2726             if $key =~ m/^(?:\Q$alias\E\.)?([^.]+)$/;
2727             }
2728              
2729 14424         79707 return \%unaliased;
2730             }
2731              
2732             =head2 as_query
2733              
2734             =over 4
2735              
2736             =item Arguments: none
2737              
2738             =item Return Value: \[ $sql, L<@bind_values|/DBIC BIND VALUES> ]
2739              
2740             =back
2741              
2742             Returns the SQL query and bind vars associated with the invocant.
2743              
2744             This is generally used as the RHS for a subquery.
2745              
2746             =cut
2747              
2748             sub as_query {
2749 663     663 1 195469 my $self = shift;
2750              
2751 663         829 my $attrs = { %{ $self->_resolved_attrs } };
  663         1941  
2752              
2753             my $aq = $self->result_source->storage->_select_args_to_query (
2754 663         3475 $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
2755             );
2756              
2757 659         7920 $aq;
2758             }
2759              
2760             =head2 find_or_new
2761              
2762             =over 4
2763              
2764             =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }?
2765              
2766             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
2767              
2768             =back
2769              
2770             my $artist = $schema->resultset('Artist')->find_or_new(
2771             { artist => 'fred' }, { key => 'artists' });
2772              
2773             $cd->cd_to_producer->find_or_new({ producer => $producer },
2774             { key => 'primary' });
2775              
2776             Find an existing record from this resultset using L. if none exists,
2777             instantiate a new result object and return it. The object will not be saved
2778             into your storage until you call L on it.
2779              
2780             You most likely want this method when looking for existing rows using a unique
2781             constraint that is not the primary key, or looking for related rows.
2782              
2783             If you want objects to be saved immediately, use L instead.
2784              
2785             B: Make sure to read the documentation of L and understand the
2786             significance of the C attribute, as its lack may skew your search, and
2787             subsequently result in spurious new objects.
2788              
2789             B: Take care when using C with a table having
2790             columns with default values that you intend to be automatically
2791             supplied by the database (e.g. an auto_increment primary key column).
2792             In normal usage, the value of such columns should NOT be included at
2793             all in the call to C, even when set to C.
2794              
2795             =cut
2796              
2797             sub find_or_new {
2798 4     4 1 8 my $self = shift;
2799 4 100 66     29 my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
2800 4 50       17 my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
2801 4 100 66     31 if (keys %$hash and my $row = $self->find($hash, $attrs) ) {
2802 2         7 return $row;
2803             }
2804 2         12 return $self->new_result($hash);
2805             }
2806              
2807             =head2 create
2808              
2809             =over 4
2810              
2811             =item Arguments: \%col_data
2812              
2813             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
2814              
2815             =back
2816              
2817             Attempt to create a single new row or a row with multiple related rows
2818             in the table represented by the resultset (and related tables). This
2819             will not check for duplicate rows before inserting, use
2820             L to do that.
2821              
2822             To create one row for this resultset, pass a hashref of key/value
2823             pairs representing the columns of the table and the values you wish to
2824             store. If the appropriate relationships are set up, foreign key fields
2825             can also be passed an object representing the foreign row, and the
2826             value will be set to its primary key.
2827              
2828             To create related objects, pass a hashref of related-object column values
2829             B. If the relationship is of type C
2830             (L) - pass an arrayref of hashrefs.
2831             The process will correctly identify columns holding foreign keys, and will
2832             transparently populate them from the keys of the corresponding relation.
2833             This can be applied recursively, and will work correctly for a structure
2834             with an arbitrary depth and width, as long as the relationships actually
2835             exists and the correct column data has been supplied.
2836              
2837             Instead of hashrefs of plain related data (key/value pairs), you may
2838             also pass new or inserted objects. New objects (not inserted yet, see
2839             L), will be inserted into their appropriate tables.
2840              
2841             Effectively a shortcut for C<< ->new_result(\%col_data)->insert >>.
2842              
2843             Example of creating a new row.
2844              
2845             $person_rs->create({
2846             name=>"Some Person",
2847             email=>"somebody@someplace.com"
2848             });
2849              
2850             Example of creating a new row and also creating rows in a related C
2851             or C resultset. Note Arrayref.
2852              
2853             $artist_rs->create(
2854             { artistid => 4, name => 'Manufactured Crap', cds => [
2855             { title => 'My First CD', year => 2006 },
2856             { title => 'Yet More Tweeny-Pop crap', year => 2007 },
2857             ],
2858             },
2859             );
2860              
2861             Example of creating a new row and also creating a row in a related
2862             C resultset. Note Hashref.
2863              
2864             $cd_rs->create({
2865             title=>"Music for Silly Walks",
2866             year=>2000,
2867             artist => {
2868             name=>"Silly Musician",
2869             }
2870             });
2871              
2872             =over
2873              
2874             =item WARNING
2875              
2876             When subclassing ResultSet never attempt to override this method. Since
2877             it is a simple shortcut for C<< $self->new_result($attrs)->insert >>, a
2878             lot of the internals simply never call it, so your override will be
2879             bypassed more often than not. Override either L
2880             or L depending on how early in the
2881             L process you need to intervene. See also warning pertaining to
2882             L.
2883              
2884             =back
2885              
2886             =cut
2887              
2888             sub create {
2889             #my ($self, $col_data) = @_;
2890 387     387 1 8190 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
2891 387         1786 return shift->new_result(shift)->insert;
2892             }
2893              
2894             =head2 find_or_create
2895              
2896             =over 4
2897              
2898             =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }?
2899              
2900             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
2901              
2902             =back
2903              
2904             $cd->cd_to_producer->find_or_create({ producer => $producer },
2905             { key => 'primary' });
2906              
2907             Tries to find a record based on its primary key or unique constraints; if none
2908             is found, creates one and returns that instead.
2909              
2910             my $cd = $schema->resultset('CD')->find_or_create({
2911             cdid => 5,
2912             artist => 'Massive Attack',
2913             title => 'Mezzanine',
2914             year => 2005,
2915             });
2916              
2917             Also takes an optional C attribute, to search by a specific key or unique
2918             constraint. For example:
2919              
2920             my $cd = $schema->resultset('CD')->find_or_create(
2921             {
2922             artist => 'Massive Attack',
2923             title => 'Mezzanine',
2924             },
2925             { key => 'cd_artist_title' }
2926             );
2927              
2928             B: Make sure to read the documentation of L and understand the
2929             significance of the C attribute, as its lack may skew your search, and
2930             subsequently result in spurious row creation.
2931              
2932             B: Because find_or_create() reads from the database and then
2933             possibly inserts based on the result, this method is subject to a race
2934             condition. Another process could create a record in the table after
2935             the find has completed and before the create has started. To avoid
2936             this problem, use find_or_create() inside a transaction.
2937              
2938             B: Take care when using C with a table having
2939             columns with default values that you intend to be automatically
2940             supplied by the database (e.g. an auto_increment primary key column).
2941             In normal usage, the value of such columns should NOT be included at
2942             all in the call to C, even when set to C.
2943              
2944             See also L and L. For information on how to declare
2945             unique constraints, see L.
2946              
2947             If you need to know if an existing row was found or a new one created use
2948             L and L instead. Don't forget
2949             to call L to save the newly created row to the
2950             database!
2951              
2952             my $cd = $schema->resultset('CD')->find_or_new({
2953             cdid => 5,
2954             artist => 'Massive Attack',
2955             title => 'Mezzanine',
2956             year => 2005,
2957             });
2958              
2959             if( !$cd->in_storage ) {
2960             # do some stuff
2961             $cd->insert;
2962             }
2963              
2964             =cut
2965              
2966             sub find_or_create {
2967 30     30 1 92 my $self = shift;
2968 30 100 66     190 my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
2969 30 50       131 my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
2970 30 100 66     229 if (keys %$hash and my $row = $self->find($hash, $attrs) ) {
2971 7         134 return $row;
2972             }
2973 21         346 return $self->new_result($hash)->insert;
2974             }
2975              
2976             =head2 update_or_create
2977              
2978             =over 4
2979              
2980             =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }?
2981              
2982             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
2983              
2984             =back
2985              
2986             $resultset->update_or_create({ col => $val, ... });
2987              
2988             Like L, but if a row is found it is immediately updated via
2989             C<< $found_row->update (\%col_data) >>.
2990              
2991              
2992             Takes an optional C attribute to search on a specific unique constraint.
2993             For example:
2994              
2995             # In your application
2996             my $cd = $schema->resultset('CD')->update_or_create(
2997             {
2998             artist => 'Massive Attack',
2999             title => 'Mezzanine',
3000             year => 1998,
3001             },
3002             { key => 'cd_artist_title' }
3003             );
3004              
3005             $cd->cd_to_producer->update_or_create({
3006             producer => $producer,
3007             name => 'harry',
3008             }, {
3009             key => 'primary',
3010             });
3011              
3012             B: Make sure to read the documentation of L and understand the
3013             significance of the C attribute, as its lack may skew your search, and
3014             subsequently result in spurious row creation.
3015              
3016             B: Take care when using C with a table having
3017             columns with default values that you intend to be automatically
3018             supplied by the database (e.g. an auto_increment primary key column).
3019             In normal usage, the value of such columns should NOT be included at
3020             all in the call to C, even when set to C.
3021              
3022             See also L and L. For information on how to declare
3023             unique constraints, see L.
3024              
3025             If you need to know if an existing row was updated or a new one created use
3026             L and L instead. Don't forget
3027             to call L to save the newly created row to the
3028             database!
3029              
3030             =cut
3031              
3032             sub update_or_create {
3033 13     13 1 22 my $self = shift;
3034 13 100 66     109 my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
3035 13 50       42 my $cond = ref $_[0] eq 'HASH' ? shift : {@_};
3036              
3037 13         44 my $row = $self->find($cond, $attrs);
3038 13 100       49 if (defined $row) {
3039 8         92 $row->update($cond);
3040 8         29 return $row;
3041             }
3042              
3043 5         29 return $self->new_result($cond)->insert;
3044             }
3045              
3046             =head2 update_or_new
3047              
3048             =over 4
3049              
3050             =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }?
3051              
3052             =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
3053              
3054             =back
3055              
3056             $resultset->update_or_new({ col => $val, ... });
3057              
3058             Like L but if a row is found it is immediately updated via
3059             C<< $found_row->update (\%col_data) >>.
3060              
3061             For example:
3062              
3063             # In your application
3064             my $cd = $schema->resultset('CD')->update_or_new(
3065             {
3066             artist => 'Massive Attack',
3067             title => 'Mezzanine',
3068             year => 1998,
3069             },
3070             { key => 'cd_artist_title' }
3071             );
3072              
3073             if ($cd->in_storage) {
3074             # the cd was updated
3075             }
3076             else {
3077             # the cd is not yet in the database, let's insert it
3078             $cd->insert;
3079             }
3080              
3081             B: Make sure to read the documentation of L and understand the
3082             significance of the C attribute, as its lack may skew your search, and
3083             subsequently result in spurious new objects.
3084              
3085             B: Take care when using C with a table having
3086             columns with default values that you intend to be automatically
3087             supplied by the database (e.g. an auto_increment primary key column).
3088             In normal usage, the value of such columns should NOT be included at
3089             all in the call to C, even when set to C.
3090              
3091             See also L, L and L.
3092              
3093             =cut
3094              
3095             sub update_or_new {
3096 2     2 1 3 my $self = shift;
3097 2 50 33     19 my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} );
3098 2 50       8 my $cond = ref $_[0] eq 'HASH' ? shift : {@_};
3099              
3100 2         7 my $row = $self->find( $cond, $attrs );
3101 2 100       7 if ( defined $row ) {
3102 1         6 $row->update($cond);
3103 1         4 return $row;
3104             }
3105              
3106 1         6 return $self->new_result($cond);
3107             }
3108              
3109             =head2 get_cache
3110              
3111             =over 4
3112              
3113             =item Arguments: none
3114              
3115             =item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> | undef
3116              
3117             =back
3118              
3119             Gets the contents of the cache for the resultset, if the cache is set.
3120              
3121             The cache is populated either by using the L attribute to
3122             L or by calling L.
3123              
3124             =cut
3125              
3126             sub get_cache {
3127 44078     44078 1 168575 shift->{all_cache};
3128             }
3129              
3130             =head2 set_cache
3131              
3132             =over 4
3133              
3134             =item Arguments: L<\@result_objs|DBIx::Class::Manual::ResultClass>
3135              
3136             =item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass>
3137              
3138             =back
3139              
3140             Sets the contents of the cache for the resultset. Expects an arrayref
3141             of objects of the same class as those produced by the resultset. Note that
3142             if the cache is set, the resultset will return the cached objects rather
3143             than re-querying the database even if the cache attr is not set.
3144              
3145             The contents of the cache can also be populated by using the
3146             L attribute to L.
3147              
3148             =cut
3149              
3150             sub set_cache {
3151 798     798 1 2914 my ( $self, $data ) = @_;
3152 798 50 66     3458 $self->throw_exception("set_cache requires an arrayref")
3153             if defined($data) && (ref $data ne 'ARRAY');
3154 798         1995 $self->{all_cache} = $data;
3155             }
3156              
3157             =head2 clear_cache
3158              
3159             =over 4
3160              
3161             =item Arguments: none
3162              
3163             =item Return Value: undef
3164              
3165             =back
3166              
3167             Clears the cache for the resultset.
3168              
3169             =cut
3170              
3171             sub clear_cache {
3172 2     2 1 7 shift->set_cache(undef);
3173             }
3174              
3175             =head2 is_paged
3176              
3177             =over 4
3178              
3179             =item Arguments: none
3180              
3181             =item Return Value: true, if the resultset has been paginated
3182              
3183             =back
3184              
3185             =cut
3186              
3187             sub is_paged {
3188 2     2 1 11 my ($self) = @_;
3189 2         13 return !!$self->{attrs}{page};
3190             }
3191              
3192             =head2 is_ordered
3193              
3194             =over 4
3195              
3196             =item Arguments: none
3197              
3198             =item Return Value: true, if the resultset has been ordered with C.
3199              
3200             =back
3201              
3202             =cut
3203              
3204             sub is_ordered {
3205 14     14 1 71 my ($self) = @_;
3206 14         57 return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by});
3207             }
3208              
3209             =head2 related_resultset
3210              
3211             =over 4
3212              
3213             =item Arguments: $rel_name
3214              
3215             =item Return Value: L<$resultset|/search>
3216              
3217             =back
3218              
3219             Returns a related resultset for the supplied relationship name.
3220              
3221             $artist_rs = $schema->resultset('CD')->related_resultset('Artist');
3222              
3223             =cut
3224              
3225             sub related_resultset {
3226 230     230 1 2792 my ($self, $rel) = @_;
3227              
3228             return $self->{related_resultsets}{$rel}
3229 230 100       942 if defined $self->{related_resultsets}{$rel};
3230              
3231 216         242 return $self->{related_resultsets}{$rel} = do {
3232 216         494 my $rsrc = $self->result_source;
3233 216         938 my $rel_info = $rsrc->relationship_info($rel);
3234              
3235 216 50       551 $self->throw_exception(
3236             "search_related: result source '" . $rsrc->source_name .
3237             "' has no such relationship $rel")
3238             unless $rel_info;
3239              
3240 216         767 my $attrs = $self->_chain_relationship($rel);
3241              
3242 216         403 my $join_count = $attrs->{seen_join}{$rel};
3243              
3244 216         980 my $alias = $self->result_source->storage
3245             ->relname_to_table_alias($rel, $join_count);
3246              
3247             # since this is search_related, and we already slid the select window inwards
3248             # (the select/as attrs were deleted in the beginning), we need to flip all
3249             # left joins to inner, so we get the expected results
3250             # read the comment on top of the actual function to see what this does
3251 216         754 $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias);
3252              
3253              
3254             #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi
3255 216         627 delete @{$attrs}{qw(result_class alias)};
  216         423  
3256              
3257 216         648 my $rel_source = $rsrc->related_source($rel);
3258              
3259 216         766 my $new = do {
3260              
3261             # The reason we do this now instead of passing the alias to the
3262             # search_rs below is that if you wrap/overload resultset on the
3263             # source you need to know what alias it's -going- to have for things
3264             # to work sanely (e.g. RestrictWithObject wants to be able to add
3265             # extra query restrictions, and these may need to be $alias.)
3266              
3267 216         707 my $rel_attrs = $rel_source->resultset_attributes;
3268 216         494 local $rel_attrs->{alias} = $alias;
3269              
3270             $rel_source->resultset
3271             ->search_rs(
3272             undef, {
3273             %$attrs,
3274             where => $attrs->{where},
3275 216         1385 });
3276             };
3277              
3278 216 100       887 if (my $cache = $self->get_cache) {
3279             my @related_cache = map
3280 13 100       29 { $_->related_resultset($rel)->get_cache || () }
  39         108  
3281             @$cache
3282             ;
3283              
3284 13 100       66 $new->set_cache([ map @$_, @related_cache ]) if @related_cache == @$cache;
3285             }
3286              
3287 216         1194 $new;
3288             };
3289             }
3290              
3291             =head2 current_source_alias
3292              
3293             =over 4
3294              
3295             =item Arguments: none
3296              
3297             =item Return Value: $source_alias
3298              
3299             =back
3300              
3301             Returns the current table alias for the result source this resultset is built
3302             on, that will be used in the SQL query. Usually it is C.
3303              
3304             Currently the source alias that refers to the result set returned by a
3305             L/L family method depends on how you got to the resultset: it's
3306             C by default, but eg. L aliases it to the related result
3307             source name (and keeps C referring to the original result set). The long
3308             term goal is to make L always alias the current resultset as C
3309             (and make this method unnecessary).
3310              
3311             Thus it's currently necessary to use this method in predefined queries (see
3312             L) when referring to the
3313             source alias of the current result set:
3314              
3315             # in a result set class
3316             sub modified_by {
3317             my ($self, $user) = @_;
3318              
3319             my $me = $self->current_source_alias;
3320              
3321             return $self->search({
3322             "$me.modified" => $user->id,
3323             });
3324             }
3325              
3326             The alias of L can be altered by the
3327             L.
3328              
3329             =cut
3330              
3331             sub current_source_alias {
3332 717   50 717 1 4256 return (shift->{attrs} || {})->{alias} || 'me';
3333             }
3334              
3335             =head2 as_subselect_rs
3336              
3337             =over 4
3338              
3339             =item Arguments: none
3340              
3341             =item Return Value: L<$resultset|/search>
3342              
3343             =back
3344              
3345             Act as a barrier to SQL symbols. The resultset provided will be made into a
3346             "virtual view" by including it as a subquery within the from clause. From this
3347             point on, any joined tables are inaccessible to ->search on the resultset (as if
3348             it were simply where-filtered without joins). For example:
3349              
3350             my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' });
3351              
3352             # 'x' now pollutes the query namespace
3353              
3354             # So the following works as expected
3355             my $ok_rs = $rs->search({'x.other' => 1});
3356              
3357             # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and
3358             # def) we look for one row with contradictory terms and join in another table
3359             # (aliased 'x_2') which we never use
3360             my $broken_rs = $rs->search({'x.name' => 'def'});
3361              
3362             my $rs2 = $rs->as_subselect_rs;
3363              
3364             # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away
3365             my $not_joined_rs = $rs2->search({'x.other' => 1});
3366              
3367             # works as expected: finds a 'table' row related to two x rows (abc and def)
3368             my $correctly_joined_rs = $rs2->search({'x.name' => 'def'});
3369              
3370             Another example of when one might use this would be to select a subset of
3371             columns in a group by clause:
3372              
3373             my $rs = $schema->resultset('Bar')->search(undef, {
3374             group_by => [qw{ id foo_id baz_id }],
3375             })->as_subselect_rs->search(undef, {
3376             columns => [qw{ id foo_id }]
3377             });
3378              
3379             In the above example normally columns would have to be equal to the group by,
3380             but because we isolated the group by into a subselect the above works.
3381              
3382             =cut
3383              
3384             sub as_subselect_rs {
3385 109     109 1 207 my $self = shift;
3386              
3387 109         286 my $attrs = $self->_resolved_attrs;
3388              
3389 109         492 my $fresh_rs = (ref $self)->new (
3390             $self->result_source
3391             );
3392              
3393             # these pieces will be locked in the subquery
3394 109         196 delete $fresh_rs->{cond};
3395 109         158 delete @{$fresh_rs->{attrs}}{qw/where bind/};
  109         226  
3396              
3397             return $fresh_rs->search( {}, {
3398             from => [{
3399             $attrs->{alias} => $self->as_query,
3400             -alias => $attrs->{alias},
3401             -rsrc => $self->result_source,
3402             }],
3403             alias => $attrs->{alias},
3404 109         495 });
3405             }
3406              
3407             # This code is called by search_related, and makes sure there
3408             # is clear separation between the joins before, during, and
3409             # after the relationship. This information is needed later
3410             # in order to properly resolve prefetch aliases (any alias
3411             # with a relation_chain_depth less than the depth of the
3412             # current prefetch is not considered)
3413             #
3414             # The increments happen twice per join. An even number means a
3415             # relationship specified via a search_related, whereas an odd
3416             # number indicates a join/prefetch added via attributes
3417             #
3418             # Also this code will wrap the current resultset (the one we
3419             # chain to) in a subselect IFF it contains limiting attributes
3420             sub _chain_relationship {
3421 216     216   304 my ($self, $rel) = @_;
3422 216         456 my $source = $self->result_source;
3423 216 50       246 my $attrs = { %{$self->{attrs}||{}} };
  216         1421  
3424              
3425             # we need to take the prefetch the attrs into account before we
3426             # ->_resolve_join as otherwise they get lost - captainL
3427 216         1084 my $join = $self->_merge_joinpref_attr( $attrs->{join}, $attrs->{prefetch} );
3428              
3429 216         562 delete @{$attrs}{qw/join prefetch collapse group_by distinct _grouped_by_distinct select as columns +select +as +columns/};
  216         553  
3430              
3431 216 100       279 my $seen = { %{ (delete $attrs->{seen_join}) || {} } };
  216         1094  
3432              
3433 216         352 my $from;
3434 216         573 my @force_subq_attrs = qw/offset rows group_by having/;
3435              
3436 216 100 66     1489 if (
    100 66        
3437             ($attrs->{from} && ref $attrs->{from} ne 'ARRAY')
3438             ||
3439             $self->_has_resolved_attr (@force_subq_attrs)
3440             ) {
3441             # Nuke the prefetch (if any) before the new $rs attrs
3442             # are resolved (prefetch is useless - we are wrapping
3443             # a subquery anyway).
3444 9         32 my $rs_copy = $self->search;
3445             $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr (
3446             $rs_copy->{attrs}{join},
3447             delete $rs_copy->{attrs}{prefetch},
3448 9         45 );
3449              
3450             $from = [{
3451             -rsrc => $source,
3452             -alias => $attrs->{alias},
3453 9         69 $attrs->{alias} => $rs_copy->as_query,
3454             }];
3455 9         24 delete @{$attrs}{@force_subq_attrs, qw/where bind/};
  9         32  
3456 9         57 $seen->{-relation_chain_depth} = 0;
3457             }
3458             elsif ($attrs->{from}) { #shallow copy suffices
3459 22         34 $from = [ @{$attrs->{from}} ];
  22         69  
3460             }
3461             else {
3462             $from = [{
3463             -rsrc => $source,
3464             -alias => $attrs->{alias},
3465 185         854 $attrs->{alias} => $source->from,
3466             }];
3467             }
3468              
3469             my $jpath = ($seen->{-relation_chain_depth})
3470             ? $from->[-1][0]{-join_path}
3471 216 100       710 : [];
3472              
3473             my @requested_joins = $source->_resolve_join(
3474             $join,
3475             $attrs->{alias},
3476 216         1255 $seen,
3477             $jpath,
3478             );
3479              
3480 216         355 push @$from, @requested_joins;
3481              
3482 216         549 $seen->{-relation_chain_depth}++;
3483              
3484             # if $self already had a join/prefetch specified on it, the requested
3485             # $rel might very well be already included. What we do in this case
3486             # is effectively a no-op (except that we bump up the chain_depth on
3487             # the join in question so we could tell it *is* the search_related)
3488 216         259 my $already_joined;
3489              
3490             # we consider the last one thus reverse
3491 216         461 for my $j (reverse @requested_joins) {
3492 30         43 my ($last_j) = keys %{$j->[0]{-join_path}[-1]};
  30         121  
3493 30 100       110 if ($rel eq $last_j) {
3494 12         33 $j->[0]{-relation_chain_depth}++;
3495 12         20 $already_joined++;
3496 12         25 last;
3497             }
3498             }
3499              
3500 216 100       455 unless ($already_joined) {
3501             push @$from, $source->_resolve_join(
3502             $rel,
3503             $attrs->{alias},
3504 204         614 $seen,
3505             $jpath,
3506             );
3507             }
3508              
3509 216         538 $seen->{-relation_chain_depth}++;
3510              
3511 216         1567 return {%$attrs, from => $from, seen_join => $seen};
3512             }
3513              
3514             sub _resolved_attrs {
3515 20782     20782   21575 my $self = shift;
3516 20782 100       61384 return $self->{_attrs} if $self->{_attrs};
3517              
3518 8960 50       8654 my $attrs = { %{ $self->{attrs} || {} } };
  8960         54965  
3519 8960         24666 my $source = $attrs->{result_source} = $self->result_source;
3520 8960         11958 my $alias = $attrs->{alias};
3521              
3522             $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported")
3523 8960 50 66     18632 if $attrs->{collapse} and $attrs->{distinct};
3524              
3525             # default selection list
3526             $attrs->{columns} = [ $source->columns ]
3527 8960 100   30796   43247 unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/;
  30796         56313  
3528              
3529             # merge selectors together
3530 8960         29742 for (qw/columns select as/) {
3531             $attrs->{$_} = $self->_merge_attr($attrs->{$_}, delete $attrs->{"+$_"})
3532 26880 100 100     118701 if $attrs->{$_} or $attrs->{"+$_"};
3533             }
3534              
3535             # disassemble columns
3536 8960         10081 my (@sel, @as);
3537 8960 100       23443 if (my $cols = delete $attrs->{columns}) {
3538 7845 50       21486 for my $c (ref $cols eq 'ARRAY' ? @$cols : $cols) {
3539 35737 100       39387 if (ref $c eq 'HASH') {
3540 1065         2946 for my $as (sort keys %$c) {
3541 1132         2160 push @sel, $c->{$as};
3542 1132         2333 push @as, $as;
3543             }
3544             }
3545             else {
3546 34672         35868 push @sel, $c;
3547 34672         36440 push @as, $c;
3548             }
3549             }
3550             }
3551              
3552             # when trying to weed off duplicates later do not go past this point -
3553             # everything added from here on is unbalanced "anyone's guess" stuff
3554 8960         12265 my $dedup_stop_idx = $#as;
3555              
3556 1165 50       4857 push @as, @{ ref $attrs->{as} eq 'ARRAY' ? $attrs->{as} : [ $attrs->{as} ] }
3557 8960 100       18949 if $attrs->{as};
3558 1170 50       3724 push @sel, @{ ref $attrs->{select} eq 'ARRAY' ? $attrs->{select} : [ $attrs->{select} ] }
3559 8960 100       19663 if $attrs->{select};
3560              
3561             # assume all unqualified selectors to apply to the current alias (legacy stuff)
3562 8960 100 100     121087 $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" for @sel;
3563              
3564             # disqualify all $alias.col as-bits (inflate-map mandated)
3565 8960 100       97226 $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_ for @as;
3566              
3567             # de-duplicate the result (remove *identical* select/as pairs)
3568             # and also die on duplicate {as} pointing to different {select}s
3569             # not using a c-style for as the condition is prone to shrinkage
3570 8960         9097 my $seen;
3571 8960         10736 my $i = 0;
3572 8960         19047 while ($i <= $dedup_stop_idx) {
3573 35804 100       124945 if ($seen->{"$sel[$i] \x00\x00 $as[$i]"}++) {
    50          
3574 10         20 splice @sel, $i, 1;
3575 10         14 splice @as, $i, 1;
3576 10         24 $dedup_stop_idx--;
3577             }
3578             elsif ($seen->{$as[$i]}++) {
3579 0         0 $self->throw_exception(
3580             "inflate_result() alias '$as[$i]' specified twice with different SQL-side {select}-ors"
3581             );
3582             }
3583             else {
3584 35794         51160 $i++;
3585             }
3586             }
3587              
3588 8960         15663 $attrs->{select} = \@sel;
3589 8960         14348 $attrs->{as} = \@as;
3590              
3591             $attrs->{from} ||= [{
3592             -rsrc => $source,
3593             -alias => $self->{attrs}{alias},
3594 8960   100     60210 $self->{attrs}{alias} => $source->from,
3595             }];
3596              
3597 8960 100 66     34743 if ( $attrs->{join} || $attrs->{prefetch} ) {
3598              
3599             $self->throw_exception ('join/prefetch can not be used with a custom {from}')
3600 720 50       2393 if ref $attrs->{from} ne 'ARRAY';
3601              
3602 720   100     2694 my $join = (delete $attrs->{join}) || {};
3603              
3604 720 100       1962 if ( defined $attrs->{prefetch} ) {
3605 485         1786 $join = $self->_merge_joinpref_attr( $join, $attrs->{prefetch} );
3606             }
3607              
3608             $attrs->{from} = # have to copy here to avoid corrupting the original
3609             [
3610 720         1494 @{ $attrs->{from} },
3611             $source->_resolve_join(
3612             $join,
3613             $alias,
3614 720 100       8782 { %{ $attrs->{seen_join} || {} } },
3615             ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
3616             ? $attrs->{from}[-1][0]{-join_path}
3617 720 100 100     1130 : []
3618             ,
3619             )
3620             ];
3621             }
3622              
3623 8960         15644 for my $attr (qw(order_by group_by)) {
3624              
3625 17920 100       35714 if ( defined $attrs->{$attr} ) {
3626             $attrs->{$attr} = (
3627             ref( $attrs->{$attr} ) eq 'ARRAY'
3628 630         1960 ? [ @{ $attrs->{$attr} } ]
3629 3579 100 66     15142 : [ $attrs->{$attr} || () ]
3630             );
3631              
3632 3579 100       4033 delete $attrs->{$attr} unless @{$attrs->{$attr}};
  3579         9422  
3633             }
3634             }
3635              
3636             # generate selections based on the prefetch helper
3637 8960         8725 my ($prefetch, @prefetch_select, @prefetch_as);
3638             $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} )
3639 8960 100       18148 if defined $attrs->{prefetch};
3640              
3641 8960 100       17328 if ($prefetch) {
3642              
3643             $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}")
3644 353 100       1086 if $attrs->{_dark_selector};
3645              
3646             $self->throw_exception("Specifying prefetch in conjunction with an explicit collapse => 0 is unsupported")
3647 352 50 33     1248 if defined $attrs->{collapse} and ! $attrs->{collapse};
3648              
3649 352         731 $attrs->{collapse} = 1;
3650              
3651             # this is a separate structure (we don't look in {from} directly)
3652             # as the resolver needs to shift things off the lists to work
3653             # properly (identical-prefetches on different branches)
3654 352         621 my $join_map = {};
3655 352 50       1184 if (ref $attrs->{from} eq 'ARRAY') {
3656              
3657 352   100     2196 my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0;
3658              
3659 352         736 for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) {
  352         947  
  352         760  
3660 529 50       1466 next unless $j->[0]{-alias};
3661 529 50       1376 next unless $j->[0]{-join_path};
3662 529 100 50     1798 next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth;
3663              
3664 517         618 my @jpath = map { keys %$_ } @{$j->[0]{-join_path}};
  756         2004  
  517         1103  
3665              
3666 517         725 my $p = $join_map;
3667 517   100     3431 $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries
3668 517         586 push @{$p->{-join_aliases} }, $j->[0]{-alias};
  517         2069  
3669             }
3670             }
3671              
3672 352         2975 my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map );
3673              
3674             # save these for after distinct resolution
3675 352         751 @prefetch_select = map { $_->[0] } @prefetch;
  1848         2354  
3676 352         1094 @prefetch_as = map { $_->[1] } @prefetch;
  1848         2837  
3677             }
3678              
3679             # run through the resulting joinstructure (starting from our current slot)
3680             # and unset collapse if proven unnecessary
3681             #
3682             # also while we are at it find out if the current root source has
3683             # been premultiplied by previous related_source chaining
3684             #
3685             # this allows to predict whether a root object with all other relation
3686             # data set to NULL is in fact unique
3687 8959 100       17378 if ($attrs->{collapse}) {
3688              
3689 388 50       1378 if (ref $attrs->{from} eq 'ARRAY') {
3690              
3691 388 100       444 if (@{$attrs->{from}} == 1) {
  388         1318  
3692             # no joins - no collapse
3693 63         198 $attrs->{collapse} = 0;
3694             }
3695             else {
3696             # find where our table-spec starts
3697 325         461 my @fromlist = @{$attrs->{from}};
  325         772  
3698 325         977 while (@fromlist) {
3699 373         597 my $t = shift @fromlist;
3700              
3701 373         507 my $is_multi;
3702             # me vs join from-spec distinction - a ref means non-root
3703 373 100       1314 if (ref $t eq 'ARRAY') {
3704 48         66 $t = $t->[0];
3705 48   66     181 $is_multi ||= ! $t->{-is_single};
3706             }
3707 373 100 66     2596 last if ($t->{-alias} && $t->{-alias} eq $alias);
3708 48   100     249 $attrs->{_main_source_premultiplied} ||= $is_multi;
3709             }
3710              
3711             # no non-singles remaining, nor any premultiplication - nothing to collapse
3712 325 100 66     2515 if (
3713             ! $attrs->{_main_source_premultiplied}
3714             and
3715 404     404   1535 ! List::Util::first { ! $_->[0]{-is_single} } @fromlist
3716             ) {
3717 95         235 $attrs->{collapse} = 0;
3718             }
3719             }
3720             }
3721              
3722             else {
3723             # if we can not analyze the from - err on the side of safety
3724 0         0 $attrs->{_main_source_premultiplied} = 1;
3725             }
3726             }
3727              
3728             # generate the distinct induced group_by before injecting the prefetched select/as parts
3729 8959 100       18056 if (delete $attrs->{distinct}) {
3730 70 100       168 if ($attrs->{group_by}) {
3731 1         6 carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
3732             }
3733             else {
3734 69         139 $attrs->{_grouped_by_distinct} = 1;
3735             # distinct affects only the main selection part, not what prefetch may add below
3736 69         271 ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs);
3737              
3738             # FIXME possibly ignore a rewritten order_by (may turn out to be an issue)
3739             # The thinking is: if we are collapsing the subquerying prefetch engine will
3740             # rip stuff apart for us anyway, and we do not want to have a potentially
3741             # function-converted external order_by
3742             # ( there is an explicit if ( collapse && _grouped_by_distinct ) check in DBIHacks )
3743 69 100       295 $attrs->{order_by} = $new_order unless $attrs->{collapse};
3744             }
3745             }
3746              
3747             # inject prefetch-bound selection (if any)
3748 8959         9456 push @{$attrs->{select}}, @prefetch_select;
  8959         16230  
3749 8959         8698 push @{$attrs->{as}}, @prefetch_as;
  8959         11928  
3750              
3751             $attrs->{_simple_passthrough_construction} = !(
3752             $attrs->{collapse}
3753             or
3754 8959   100     21083 grep { $_ =~ /\./ } @{$attrs->{as}}
3755             );
3756              
3757             # if both page and offset are specified, produce a combined offset
3758             # even though it doesn't make much sense, this is what pre 081xx has
3759             # been doing
3760 8959 100       19807 if (my $page = delete $attrs->{page}) {
3761             $attrs->{offset} =
3762             ($attrs->{rows} * ($page - 1))
3763             +
3764 15   100     66 ($attrs->{offset} || 0)
3765             ;
3766             }
3767              
3768 8959         59977 return $self->{_attrs} = $attrs;
3769             }
3770              
3771             sub _rollout_attr {
3772 2038     2038   2243 my ($self, $attr) = @_;
3773              
3774 2038 100       4851 if (ref $attr eq 'HASH') {
    100          
3775 734         1948 return $self->_rollout_hash($attr);
3776             } elsif (ref $attr eq 'ARRAY') {
3777 940         1669 return $self->_rollout_array($attr);
3778             } else {
3779 364         793 return [$attr];
3780             }
3781             }
3782              
3783             sub _rollout_array {
3784 1280     1280   1195 my ($self, $attr) = @_;
3785              
3786 1280         1045 my @rolled_array;
3787 1280         1050 foreach my $element (@{$attr}) {
  1280         1957  
3788 1362 100       2883 if (ref $element eq 'HASH') {
    100          
3789 474         481 push( @rolled_array, @{ $self->_rollout_hash( $element ) } );
  474         854  
3790             } elsif (ref $element eq 'ARRAY') {
3791             # XXX - should probably recurse here
3792 340         321 push( @rolled_array, @{$self->_rollout_array($element)} );
  340         575  
3793             } else {
3794 548         984 push( @rolled_array, $element );
3795             }
3796             }
3797 1280         2194 return \@rolled_array;
3798             }
3799              
3800             sub _rollout_hash {
3801 1208     1208   1345 my ($self, $attr) = @_;
3802              
3803 1208         1174 my @rolled_array;
3804 1208         1251 foreach my $key (keys %{$attr}) {
  1208         2813  
3805 242         728 push( @rolled_array, { $key => $attr->{$key} } );
3806             }
3807 1208         2532 return \@rolled_array;
3808             }
3809              
3810             sub _calculate_score {
3811 324     324   444 my ($self, $a, $b) = @_;
3812              
3813 324 100 100     1907 if (defined $a xor defined $b) {
    100          
3814 44         82 return 0;
3815             }
3816             elsif (not defined $a) {
3817 10         24 return 1;
3818             }
3819              
3820 270 100       563 if (ref $b eq 'HASH') {
3821 92         96 my ($b_key) = keys %{$b};
  92         201  
3822 92 100       214 $b_key = '' if ! defined $b_key;
3823 92 100       191 if (ref $a eq 'HASH') {
3824 35         45 my ($a_key) = keys %{$a};
  35         69  
3825 35 100       98 $a_key = '' if ! defined $a_key;
3826 35 100       71 if ($a_key eq $b_key) {
3827 25         71 return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} ));
3828             } else {
3829 10         23 return 0;
3830             }
3831             } else {
3832 57 100       152 return ($a eq $b_key) ? 1 : 0;
3833             }
3834             } else {
3835 178 100       375 if (ref $a eq 'HASH') {
3836 30         35 my ($a_key) = keys %{$a};
  30         69  
3837 30 100       101 return ($b eq $a_key) ? 1 : 0;
3838             } else {
3839 148 100       434 return ($b eq $a) ? 1 : 0;
3840             }
3841             }
3842             }
3843              
3844             sub _merge_joinpref_attr {
3845 2829     2829   16660 my ($self, $orig, $import) = @_;
3846              
3847 2829 100       8896 return $import unless defined($orig);
3848 1042 100       2101 return $orig unless defined($import);
3849              
3850 1019         2529 $orig = $self->_rollout_attr($orig);
3851 1019         2085 $import = $self->_rollout_attr($import);
3852              
3853 1019         999 my $seen_keys;
3854 1019         1059 foreach my $import_element ( @{$import} ) {
  1019         1680  
3855             # find best candidate from $orig to merge $b_element into
3856 865         2116 my $best_candidate = { position => undef, score => 0 }; my $position = 0;
  865         1342  
3857 865         805 foreach my $orig_element ( @{$orig} ) {
  865         1292  
3858 299         816 my $score = $self->_calculate_score( $orig_element, $import_element );
3859 299 100       743 if ($score > $best_candidate->{score}) {
3860 90         112 $best_candidate->{position} = $position;
3861 90         144 $best_candidate->{score} = $score;
3862             }
3863 299         425 $position++;
3864             }
3865 865 100       1970 my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
  176         345  
3866 865 100       2001 $import_key = '' if not defined $import_key;
3867              
3868 865 100 66     2546 if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
3869 794         792 push( @{$orig}, $import_element );
  794         1304  
3870             } else {
3871 71         117 my $orig_best = $orig->[$best_candidate->{position}];
3872             # merge orig_best and b_element together and replace original with merged
3873 71 100       187 if (ref $orig_best ne 'HASH') {
    100          
3874 46         82 $orig->[$best_candidate->{position}] = $import_element;
3875             } elsif (ref $import_element eq 'HASH') {
3876 15         25 my ($key) = keys %{$orig_best};
  15         28  
3877 15         59 $orig->[$best_candidate->{position}] = { $key => $self->_merge_joinpref_attr($orig_best->{$key}, $import_element->{$key}) };
3878             }
3879             }
3880 865         2347 $seen_keys->{$import_key} = 1; # don't merge the same key twice
3881             }
3882              
3883 1019 100       3008 return @$orig ? $orig : ();
3884             }
3885              
3886             {
3887             my $hm;
3888              
3889             sub _merge_attr {
3890 17197   66 17197   31669 $hm ||= do {
3891 185         110813 require Hash::Merge;
3892 185         430914 my $hm = Hash::Merge->new;
3893              
3894             $hm->specify_behavior({
3895             SCALAR => {
3896             SCALAR => sub {
3897 72     72   1462 my ($defl, $defr) = map { defined $_ } (@_[0,1]);
  144         355  
3898              
3899 72 50 25     475 if ($defl xor $defr) {
    0          
3900 72 50       474 return [ $defl ? $_[0] : $_[1] ];
3901             }
3902             elsif (! $defl) {
3903 0         0 return [];
3904             }
3905             elsif (__HM_DEDUP and $_[0] eq $_[1]) {
3906             return [ $_[0] ];
3907             }
3908             else {
3909 0         0 return [$_[0], $_[1]];
3910             }
3911             },
3912             ARRAY => sub {
3913 5909 50   5909   82461 return $_[1] if !defined $_[0];
3914 0         0 return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
3915 0         0 return [$_[0], @{$_[1]}]
  0         0  
3916             },
3917             HASH => sub {
3918 867 100 33 867   13552 return [] if !defined $_[0] and !keys %{$_[1]};
  867         2953  
3919 866 50       4483 return [ $_[1] ] if !defined $_[0];
3920 0 0       0 return [ $_[0] ] if !keys %{$_[1]};
  0         0  
3921 0         0 return [$_[0], $_[1]]
3922             },
3923             },
3924             ARRAY => {
3925             SCALAR => sub {
3926 10224 100   10224   177244 return $_[0] if !defined $_[1];
3927 1         2 return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
3928 1         2 return [@{$_[0]}, $_[1]]
  1         4  
3929             },
3930             ARRAY => sub {
3931 125 100   125   1538 my @ret = @{$_[0]} or return $_[1];
  125         536  
3932 120         202 return [ @ret, @{$_[1]} ] unless __HM_DEDUP;
  120         479  
3933 0         0 my %idx = map { $_ => 1 } @ret;
  0         0  
3934 0         0 push @ret, grep { ! defined $idx{$_} } (@{$_[1]});
  0         0  
  0         0  
3935 0         0 \@ret;
3936             },
3937             HASH => sub {
3938 0 0   0   0 return [ $_[1] ] if ! @{$_[0]};
  0         0  
3939 0 0       0 return $_[0] if !keys %{$_[1]};
  0         0  
3940 0         0 return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
3941 0         0 return [ @{$_[0]}, $_[1] ];
  0         0  
3942             },
3943             },
3944             HASH => {
3945             SCALAR => sub {
3946 0 0 0 0   0 return [] if !keys %{$_[0]} and !defined $_[1];
  0         0  
3947 0 0       0 return [ $_[0] ] if !defined $_[1];
3948 0 0       0 return [ $_[1] ] if !keys %{$_[0]};
  0         0  
3949 0         0 return [$_[0], $_[1]]
3950             },
3951             ARRAY => sub {
3952 0 0 0 0   0 return [] if !keys %{$_[0]} and !@{$_[1]};
  0         0  
  0         0  
3953 0 0       0 return [ $_[0] ] if !@{$_[1]};
  0         0  
3954 0 0       0 return $_[1] if !keys %{$_[0]};
  0         0  
3955 0         0 return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
3956 0         0 return [ $_[0], @{$_[1]} ];
  0         0  
3957             },
3958             HASH => sub {
3959 0 0 0 0   0 return [] if !keys %{$_[0]} and !keys %{$_[1]};
  0         0  
  0         0  
3960 0 0       0 return [ $_[0] ] if !keys %{$_[1]};
  0         0  
3961 0 0       0 return [ $_[1] ] if !keys %{$_[0]};
  0         0  
3962 0 0       0 return [ $_[0] ] if $_[0] eq $_[1];
3963 0         0 return [ $_[0], $_[1] ];
3964             },
3965             }
3966 185         6889 } => 'DBIC_RS_ATTR_MERGER');
3967 185         6073 $hm;
3968             };
3969              
3970 17197         51431 return $hm->merge ($_[1], $_[2]);
3971             }
3972             }
3973              
3974             sub STORABLE_freeze {
3975 146     146 0 2741 my ($self, $cloning) = @_;
3976 146         686 my $to_serialize = { %$self };
3977              
3978             # A cursor in progress can't be serialized (and would make little sense anyway)
3979             # the parser can be regenerated (and can't be serialized)
3980 146         187 delete @{$to_serialize}{qw/cursor _row_parser _result_inflator/};
  146         219  
3981              
3982             # nor is it sensical to store a not-yet-fired-count pager
3983 146 100 100     331 if ($to_serialize->{pager} and ref $to_serialize->{pager}{total_entries} eq 'CODE') {
3984 1         3 delete $to_serialize->{pager};
3985             }
3986              
3987 146         276 Storable::nfreeze($to_serialize);
3988             }
3989              
3990             # need this hook for symmetry
3991             sub STORABLE_thaw {
3992 146     146 0 1046 my ($self, $cloning, $serialized) = @_;
3993              
3994 146         100 %$self = %{ Storable::thaw($serialized) };
  146         258  
3995              
3996 146         2475 $self;
3997             }
3998              
3999              
4000             =head2 throw_exception
4001              
4002             See L for details.
4003              
4004             =cut
4005              
4006             sub throw_exception {
4007 57     57 1 2237 my $self=shift;
4008              
4009 57 100 66     313 if (ref $self and my $rsrc = $self->result_source) {
4010 56         244 $rsrc->throw_exception(@_)
4011             }
4012             else {
4013 1         5 DBIx::Class::Exception->throw(@_);
4014             }
4015             }
4016              
4017             1;
4018              
4019             __END__