File Coverage

blib/lib/DBIx/Class/ResultSet.pm
Criterion Covered Total %
statement 1064 1125 94.5
branch 570 690 82.6
condition 268 375 71.4
subroutine 162 162 100.0
pod 43 45 95.5
total 2107 2397 87.9


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