25344b7f2714c78a1cc67d05bbcc3279a4c69c47
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSet.pm
1 package DBIx::Class::ResultSet;
2
3 use strict;
4 use warnings;
5 use base qw/DBIx::Class/;
6 use Carp::Clan qw/^DBIx::Class/;
7 use DBIx::Class::Exception;
8 use Data::Page;
9 use Storable;
10 use DBIx::Class::ResultSetColumn;
11 use DBIx::Class::ResultSourceHandle;
12 use List::Util ();
13 use Scalar::Util qw/blessed weaken/;
14 use Try::Tiny;
15 use namespace::clean;
16
17 use overload
18         '0+'     => "count",
19         'bool'   => "_bool",
20         fallback => 1;
21
22 __PACKAGE__->mk_group_accessors('simple' => qw/_result_class _source_handle/);
23
24 =head1 NAME
25
26 DBIx::Class::ResultSet - Represents a query used for fetching a set of results.
27
28 =head1 SYNOPSIS
29
30   my $users_rs   = $schema->resultset('User');
31   while( $user = $users_rs->next) {
32     print $user->username;
33   }
34
35   my $registered_users_rs   = $schema->resultset('User')->search({ registered => 1 });
36   my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all();
37
38 =head1 DESCRIPTION
39
40 A ResultSet is an object which stores a set of conditions representing
41 a query. It is the backbone of DBIx::Class (i.e. the really
42 important/useful bit).
43
44 No SQL is executed on the database when a ResultSet is created, it
45 just stores all the conditions needed to create the query.
46
47 A basic ResultSet representing the data of an entire table is returned
48 by calling C<resultset> on a L<DBIx::Class::Schema> and passing in a
49 L<Source|DBIx::Class::Manual::Glossary/Source> name.
50
51   my $users_rs = $schema->resultset('User');
52
53 A new ResultSet is returned from calling L</search> on an existing
54 ResultSet. The new one will contain all the conditions of the
55 original, plus any new conditions added in the C<search> call.
56
57 A ResultSet also incorporates an implicit iterator. L</next> and L</reset>
58 can be used to walk through all the L<DBIx::Class::Row>s the ResultSet
59 represents.
60
61 The query that the ResultSet represents is B<only> executed against
62 the database when these methods are called:
63 L</find>, L</next>, L</all>, L</first>, L</single>, L</count>.
64
65 If a resultset is used in a numeric context it returns the L</count>.
66 However, if it is used in a boolean context it is B<always> true.  So if
67 you want to check if a resultset has any results, you must use C<if $rs
68 != 0>.
69
70 =head1 EXAMPLES
71
72 =head2 Chaining resultsets
73
74 Let's say you've got a query that needs to be run to return some data
75 to the user. But, you have an authorization system in place that
76 prevents certain users from seeing certain information. So, you want
77 to construct the basic query in one method, but add constraints to it in
78 another.
79
80   sub get_data {
81     my $self = shift;
82     my $request = $self->get_request; # Get a request object somehow.
83     my $schema = $self->get_schema;   # Get the DBIC schema object somehow.
84
85     my $cd_rs = $schema->resultset('CD')->search({
86       title => $request->param('title'),
87       year => $request->param('year'),
88     });
89
90     $self->apply_security_policy( $cd_rs );
91
92     return $cd_rs->all();
93   }
94
95   sub apply_security_policy {
96     my $self = shift;
97     my ($rs) = @_;
98
99     return $rs->search({
100       subversive => 0,
101     });
102   }
103
104 =head3 Resolving conditions and attributes
105
106 When a resultset is chained from another resultset, conditions and
107 attributes with the same keys need resolving.
108
109 L</join>, L</prefetch>, L</+select>, L</+as> attributes are merged
110 into the existing ones from the original resultset.
111
112 The L</where> and L</having> attributes, and any search conditions, are
113 merged with an SQL C<AND> to the existing condition from the original
114 resultset.
115
116 All other attributes are overridden by any new ones supplied in the
117 search attributes.
118
119 =head2 Multiple queries
120
121 Since a resultset just defines a query, you can do all sorts of
122 things with it with the same object.
123
124   # Don't hit the DB yet.
125   my $cd_rs = $schema->resultset('CD')->search({
126     title => 'something',
127     year => 2009,
128   });
129
130   # Each of these hits the DB individually.
131   my $count = $cd_rs->count;
132   my $most_recent = $cd_rs->get_column('date_released')->max();
133   my @records = $cd_rs->all;
134
135 And it's not just limited to SELECT statements.
136
137   $cd_rs->delete();
138
139 This is even cooler:
140
141   $cd_rs->create({ artist => 'Fred' });
142
143 Which is the same as:
144
145   $schema->resultset('CD')->create({
146     title => 'something',
147     year => 2009,
148     artist => 'Fred'
149   });
150
151 See: L</search>, L</count>, L</get_column>, L</all>, L</create>.
152
153 =head1 METHODS
154
155 =head2 new
156
157 =over 4
158
159 =item Arguments: $source, \%$attrs
160
161 =item Return Value: $rs
162
163 =back
164
165 The resultset constructor. Takes a source object (usually a
166 L<DBIx::Class::ResultSourceProxy::Table>) and an attribute hash (see
167 L</ATTRIBUTES> below).  Does not perform any queries -- these are
168 executed as needed by the other methods.
169
170 Generally you won't need to construct a resultset manually.  You'll
171 automatically get one from e.g. a L</search> called in scalar context:
172
173   my $rs = $schema->resultset('CD')->search({ title => '100th Window' });
174
175 IMPORTANT: If called on an object, proxies to new_result instead so
176
177   my $cd = $schema->resultset('CD')->new({ title => 'Spoon' });
178
179 will return a CD object, not a ResultSet.
180
181 =cut
182
183 sub new {
184   my $class = shift;
185   return $class->new_result(@_) if ref $class;
186
187   my ($source, $attrs) = @_;
188   $source = $source->handle
189     unless $source->isa('DBIx::Class::ResultSourceHandle');
190   $attrs = { %{$attrs||{}} };
191
192   if ($attrs->{page}) {
193     $attrs->{rows} ||= 10;
194   }
195
196   $attrs->{alias} ||= 'me';
197
198   # Creation of {} and bless separated to mitigate RH perl bug
199   # see https://bugzilla.redhat.com/show_bug.cgi?id=196836
200   my $self = {
201     _source_handle => $source,
202     cond => $attrs->{where},
203     pager => undef,
204     attrs => $attrs
205   };
206
207   bless $self, $class;
208
209   $self->result_class(
210     $attrs->{result_class} || $source->resolve->result_class
211   );
212
213   return $self;
214 }
215
216 =head2 search
217
218 =over 4
219
220 =item Arguments: $cond, \%attrs?
221
222 =item Return Value: $resultset (scalar context), @row_objs (list context)
223
224 =back
225
226   my @cds    = $cd_rs->search({ year => 2001 }); # "... WHERE year = 2001"
227   my $new_rs = $cd_rs->search({ year => 2005 });
228
229   my $new_rs = $cd_rs->search([ { year => 2005 }, { year => 2004 } ]);
230                  # year = 2005 OR year = 2004
231
232 If you need to pass in additional attributes but no additional condition,
233 call it as C<search(undef, \%attrs)>.
234
235   # "SELECT name, artistid FROM $artist_table"
236   my @all_artists = $schema->resultset('Artist')->search(undef, {
237     columns => [qw/name artistid/],
238   });
239
240 For a list of attributes that can be passed to C<search>, see
241 L</ATTRIBUTES>. For more examples of using this function, see
242 L<Searching|DBIx::Class::Manual::Cookbook/Searching>. For a complete
243 documentation for the first argument, see L<SQL::Abstract>.
244
245 For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
246
247 =cut
248
249 sub search {
250   my $self = shift;
251   my $rs = $self->search_rs( @_ );
252
253   my $want = wantarray;
254   if ($want) {
255     return $rs->all;
256   }
257   elsif (defined $want) {
258     return $rs;
259   }
260   else {
261     $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense');
262   }
263 }
264
265 =head2 search_rs
266
267 =over 4
268
269 =item Arguments: $cond, \%attrs?
270
271 =item Return Value: $resultset
272
273 =back
274
275 This method does the same exact thing as search() except it will
276 always return a resultset, even in list context.
277
278 =cut
279
280 sub search_rs {
281   my $self = shift;
282
283   # Special-case handling for (undef, undef).
284   if ( @_ == 2 && !defined $_[1] && !defined $_[0] ) {
285     @_ = ();
286   }
287
288   my $call_attrs = {};
289   $call_attrs = pop(@_) if (
290    @_ > 1 and ( ! defined $_[-1] or ref $_[-1] eq 'HASH' )
291   );
292
293   # see if we can keep the cache (no $rs changes)
294   my $cache;
295   my %safe = (alias => 1, cache => 1);
296   if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and (
297     ! defined $_[0]
298       or
299     ref $_[0] eq 'HASH' && ! keys %{$_[0]}
300       or
301     ref $_[0] eq 'ARRAY' && ! @{$_[0]}
302   )) {
303     $cache = $self->get_cache;
304   }
305
306   my $old_attrs = { %{$self->{attrs}} };
307   my $old_having = delete $old_attrs->{having};
308   my $old_where = delete $old_attrs->{where};
309
310   # reset the selector list
311   if (List::Util::first { exists $call_attrs->{$_} } qw{columns select as}) {
312      delete @{$old_attrs}{qw{select as columns +select +as +columns include_columns}};
313   }
314
315   my $new_attrs = { %{$old_attrs}, %{$call_attrs} };
316
317   # merge new attrs into inherited
318   foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) {
319     next unless exists $call_attrs->{$key};
320     $new_attrs->{$key} = $self->_merge_attr($old_attrs->{$key}, $call_attrs->{$key});
321   }
322
323   # rip apart the rest of @_, parse a condition
324   my $call_cond = do {
325
326     if (ref $_[0] eq 'HASH') {
327       (keys %{$_[0]}) ? $_[0] : undef
328     }
329     elsif (@_ == 1) {
330       $_[0]
331     }
332     elsif (@_ % 2) {
333       $self->throw_exception('Odd number of arguments to search')
334     }
335     else {
336       +{ @_ }
337     }
338
339   } if @_;
340
341   carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
342     if (@_ > 1 and ! $self->result_source->result_class->isa('DBIx::Class::CDBICompat') );
343
344   for ($old_where, $call_cond) {
345     if (defined $_) {
346       $new_attrs->{where} = $self->_stack_cond (
347         $_, $new_attrs->{where}
348       );
349     }
350   }
351
352   if (defined $old_having) {
353     $new_attrs->{having} = $self->_stack_cond (
354       $old_having, $new_attrs->{having}
355     )
356   }
357
358   my $rs = (ref $self)->new($self->result_source, $new_attrs);
359
360   $rs->set_cache($cache) if ($cache);
361
362   return $rs;
363 }
364
365 sub _stack_cond {
366   my ($self, $left, $right) = @_;
367   if (defined $left xor defined $right) {
368     return defined $left ? $left : $right;
369   }
370   elsif (defined $left) {
371     return { -and => [ map
372       { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
373       ($left, $right)
374     ]};
375   }
376
377   return undef;
378 }
379
380 =head2 search_literal
381
382 =over 4
383
384 =item Arguments: $sql_fragment, @bind_values
385
386 =item Return Value: $resultset (scalar context), @row_objs (list context)
387
388 =back
389
390   my @cds   = $cd_rs->search_literal('year = ? AND title = ?', qw/2001 Reload/);
391   my $newrs = $artist_rs->search_literal('name = ?', 'Metallica');
392
393 Pass a literal chunk of SQL to be added to the conditional part of the
394 resultset query.
395
396 CAVEAT: C<search_literal> is provided for Class::DBI compatibility and should
397 only be used in that context. C<search_literal> is a convenience method.
398 It is equivalent to calling $schema->search(\[]), but if you want to ensure
399 columns are bound correctly, use C<search>.
400
401 Example of how to use C<search> instead of C<search_literal>
402
403   my @cds = $cd_rs->search_literal('cdid = ? AND (artist = ? OR artist = ?)', (2, 1, 2));
404   my @cds = $cd_rs->search(\[ 'cdid = ? AND (artist = ? OR artist = ?)', [ 'cdid', 2 ], [ 'artist', 1 ], [ 'artist', 2 ] ]);
405
406
407 See L<DBIx::Class::Manual::Cookbook/Searching> and
408 L<DBIx::Class::Manual::FAQ/Searching> for searching techniques that do not
409 require C<search_literal>.
410
411 =cut
412
413 sub search_literal {
414   my ($self, $sql, @bind) = @_;
415   my $attr;
416   if ( @bind && ref($bind[-1]) eq 'HASH' ) {
417     $attr = pop @bind;
418   }
419   return $self->search(\[ $sql, map [ __DUMMY__ => $_ ], @bind ], ($attr || () ));
420 }
421
422 =head2 find
423
424 =over 4
425
426 =item Arguments: \%columns_values | @pk_values, \%attrs?
427
428 =item Return Value: $row_object | undef
429
430 =back
431
432 Finds and returns a single row based on supplied criteria. Takes either a
433 hashref with the same format as L</create> (including inference of foreign
434 keys from related objects), or a list of primary key values in the same
435 order as the L<primary columns|DBIx::Class::ResultSource/primary_columns>
436 declaration on the L</result_source>.
437
438 In either case an attempt is made to combine conditions already existing on
439 the resultset with the condition passed to this method.
440
441 To aid with preparing the correct query for the storage you may supply the
442 C<key> attribute, which is the name of a
443 L<unique constraint|DBIx::Class::ResultSource/add_unique_constraint> (the
444 unique constraint corresponding to the
445 L<primary columns|DBIx::Class::ResultSource/primary_columns> is always named
446 C<primary>). If the C<key> attribute has been supplied, and DBIC is unable
447 to construct a query that satisfies the named unique constraint fully (
448 non-NULL values for each column member of the constraint) an exception is
449 thrown.
450
451 If no C<key> is specified, the search is carried over all unique constraints
452 which are fully defined by the available condition.
453
454 If no such constraint is found, C<find> currently defaults to a simple
455 C<< search->(\%column_values) >> which may or may not do what you expect.
456 Note that this fallback behavior may be deprecated in further versions. If
457 you need to search with arbitrary conditions - use L</search>. If the query
458 resulting from this fallback produces more than one row, a warning to the
459 effect is issued, though only the first row is constructed and returned as
460 C<$row_object>.
461
462 In addition to C<key>, L</find> recognizes and applies standard
463 L<resultset attributes|/ATTRIBUTES> in the same way as L</search> does.
464
465 Note that if you have extra concerns about the correctness of the resulting
466 query you need to specify the C<key> attribute and supply the entire condition
467 as an argument to find (since it is not always possible to perform the
468 combination of the resultset condition with the supplied one, especially if
469 the resultset condition contains literal sql).
470
471 For example, to find a row by its primary key:
472
473   my $cd = $schema->resultset('CD')->find(5);
474
475 You can also find a row by a specific unique constraint:
476
477   my $cd = $schema->resultset('CD')->find(
478     {
479       artist => 'Massive Attack',
480       title  => 'Mezzanine',
481     },
482     { key => 'cd_artist_title' }
483   );
484
485 See also L</find_or_create> and L</update_or_create>.
486
487 =cut
488
489 sub find {
490   my $self = shift;
491   my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
492
493   my $rsrc = $self->result_source;
494
495   # Parse out the condition from input
496   my $call_cond;
497   if (ref $_[0] eq 'HASH') {
498     $call_cond = { %{$_[0]} };
499   }
500   else {
501     my $constraint = exists $attrs->{key} ? $attrs->{key} : 'primary';
502     my @c_cols = $rsrc->unique_constraint_columns($constraint);
503
504     $self->throw_exception(
505       "No constraint columns, maybe a malformed '$constraint' constraint?"
506     ) unless @c_cols;
507
508     $self->throw_exception (
509       'find() expects either a column/value hashref, or a list of values '
510     . "corresponding to the columns of the specified unique constraint '$constraint'"
511     ) unless @c_cols == @_;
512
513     $call_cond = {};
514     @{$call_cond}{@c_cols} = @_;
515   }
516
517   my %related;
518   for my $key (keys %$call_cond) {
519     if (
520       my $keyref = ref($call_cond->{$key})
521         and
522       my $relinfo = $rsrc->relationship_info($key)
523     ) {
524       my $val = delete $call_cond->{$key};
525
526       next if $keyref eq 'ARRAY'; # has_many for multi_create
527
528       my $rel_q = $rsrc->_resolve_condition(
529         $relinfo->{cond}, $val, $key
530       );
531       die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH';
532       @related{keys %$rel_q} = values %$rel_q;
533     }
534   }
535
536   # relationship conditions take precedence (?)
537   @{$call_cond}{keys %related} = values %related;
538
539   my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias};
540   my $final_cond;
541   if (exists $attrs->{key}) {
542     $final_cond = $self->_qualify_cond_columns (
543
544       $self->_build_unique_cond (
545         $attrs->{key},
546         $call_cond,
547       ),
548
549       $alias,
550     );
551   }
552   elsif ($self->{attrs}{accessor} and $self->{attrs}{accessor} eq 'single') {
553     # This means that we got here after a merger of relationship conditions
554     # in ::Relationship::Base::search_related (the row method), and furthermore
555     # the relationship is of the 'single' type. This means that the condition
556     # provided by the relationship (already attached to $self) is sufficient,
557     # as there can be only one row in the database that would satisfy the
558     # relationship
559   }
560   else {
561     # no key was specified - fall down to heuristics mode:
562     # run through all unique queries registered on the resultset, and
563     # 'OR' all qualifying queries together
564     my (@unique_queries, %seen_column_combinations);
565     for my $c_name ($rsrc->unique_constraint_names) {
566       next if $seen_column_combinations{
567         join "\x00", sort $rsrc->unique_constraint_columns($c_name)
568       }++;
569
570       push @unique_queries, try {
571         $self->_build_unique_cond ($c_name, $call_cond)
572       } || ();
573     }
574
575     $final_cond = @unique_queries
576       ? [ map { $self->_qualify_cond_columns($_, $alias) } @unique_queries ]
577       : $self->_non_unique_find_fallback ($call_cond, $attrs)
578     ;
579   }
580
581   # Run the query, passing the result_class since it should propagate for find
582   my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs});
583   if (keys %{$rs->_resolved_attrs->{collapse}}) {
584     my $row = $rs->next;
585     carp "Query returned more than one row" if $rs->next;
586     return $row;
587   }
588   else {
589     return $rs->single;
590   }
591 }
592
593 # This is a stop-gap method as agreed during the discussion on find() cleanup:
594 # http://lists.scsys.co.uk/pipermail/dbix-class/2010-October/009535.html
595 #
596 # It is invoked when find() is called in legacy-mode with insufficiently-unique
597 # condition. It is provided for overrides until a saner way forward is devised
598 #
599 # *NOTE* This is not a public method, and it's *GUARANTEED* to disappear down
600 # the road. Please adjust your tests accordingly to catch this situation early
601 # DBIx::Class::ResultSet->can('_non_unique_find_fallback') is reasonable
602 #
603 # The method will not be removed without an adequately complete replacement
604 # for strict-mode enforcement
605 sub _non_unique_find_fallback {
606   my ($self, $cond, $attrs) = @_;
607
608   return $self->_qualify_cond_columns(
609     $cond,
610     exists $attrs->{alias}
611       ? $attrs->{alias}
612       : $self->{attrs}{alias}
613   );
614 }
615
616
617 sub _qualify_cond_columns {
618   my ($self, $cond, $alias) = @_;
619
620   my %aliased = %$cond;
621   for (keys %aliased) {
622     $aliased{"$alias.$_"} = delete $aliased{$_}
623       if $_ !~ /\./;
624   }
625
626   return \%aliased;
627 }
628
629 sub _build_unique_cond {
630   my ($self, $constraint_name, $extra_cond) = @_;
631
632   my @c_cols = $self->result_source->unique_constraint_columns($constraint_name);
633
634   # combination may fail if $self->{cond} is non-trivial
635   my ($final_cond) = try {
636     $self->_merge_with_rscond ($extra_cond)
637   } catch {
638     +{ %$extra_cond }
639   };
640
641   # trim out everything not in $columns
642   $final_cond = { map { $_ => $final_cond->{$_} } @c_cols };
643
644   if (my @missing = grep { ! defined $final_cond->{$_} } (@c_cols) ) {
645     $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s",
646       $constraint_name,
647       join (', ', map { "'$_'" } @missing),
648     ) );
649   }
650
651   return $final_cond;
652 }
653
654 =head2 search_related
655
656 =over 4
657
658 =item Arguments: $rel, $cond, \%attrs?
659
660 =item Return Value: $new_resultset
661
662 =back
663
664   $new_rs = $cd_rs->search_related('artist', {
665     name => 'Emo-R-Us',
666   });
667
668 Searches the specified relationship, optionally specifying a condition and
669 attributes for matching records. See L</ATTRIBUTES> for more information.
670
671 =cut
672
673 sub search_related {
674   return shift->related_resultset(shift)->search(@_);
675 }
676
677 =head2 search_related_rs
678
679 This method works exactly the same as search_related, except that
680 it guarantees a resultset, even in list context.
681
682 =cut
683
684 sub search_related_rs {
685   return shift->related_resultset(shift)->search_rs(@_);
686 }
687
688 =head2 cursor
689
690 =over 4
691
692 =item Arguments: none
693
694 =item Return Value: $cursor
695
696 =back
697
698 Returns a storage-driven cursor to the given resultset. See
699 L<DBIx::Class::Cursor> for more information.
700
701 =cut
702
703 sub cursor {
704   my ($self) = @_;
705
706   my $attrs = $self->_resolved_attrs_copy;
707
708   return $self->{cursor}
709     ||= $self->result_source->storage->select($attrs->{from}, $attrs->{select},
710           $attrs->{where},$attrs);
711 }
712
713 =head2 single
714
715 =over 4
716
717 =item Arguments: $cond?
718
719 =item Return Value: $row_object | undef
720
721 =back
722
723   my $cd = $schema->resultset('CD')->single({ year => 2001 });
724
725 Inflates the first result without creating a cursor if the resultset has
726 any records in it; if not returns C<undef>. Used by L</find> as a lean version
727 of L</search>.
728
729 While this method can take an optional search condition (just like L</search>)
730 being a fast-code-path it does not recognize search attributes. If you need to
731 add extra joins or similar, call L</search> and then chain-call L</single> on the
732 L<DBIx::Class::ResultSet> returned.
733
734 =over
735
736 =item B<Note>
737
738 As of 0.08100, this method enforces the assumption that the preceding
739 query returns only one row. If more than one row is returned, you will receive
740 a warning:
741
742   Query returned more than one row
743
744 In this case, you should be using L</next> or L</find> instead, or if you really
745 know what you are doing, use the L</rows> attribute to explicitly limit the size
746 of the resultset.
747
748 This method will also throw an exception if it is called on a resultset prefetching
749 has_many, as such a prefetch implies fetching multiple rows from the database in
750 order to assemble the resulting object.
751
752 =back
753
754 =cut
755
756 sub single {
757   my ($self, $where) = @_;
758   if(@_ > 2) {
759       $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()');
760   }
761
762   my $attrs = $self->_resolved_attrs_copy;
763
764   if (keys %{$attrs->{collapse}}) {
765     $self->throw_exception(
766       'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead'
767     );
768   }
769
770   if ($where) {
771     if (defined $attrs->{where}) {
772       $attrs->{where} = {
773         '-and' =>
774             [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
775                $where, delete $attrs->{where} ]
776       };
777     } else {
778       $attrs->{where} = $where;
779     }
780   }
781
782   my @data = $self->result_source->storage->select_single(
783     $attrs->{from}, $attrs->{select},
784     $attrs->{where}, $attrs
785   );
786
787   return (@data ? ($self->_construct_object(@data))[0] : undef);
788 }
789
790
791 # _collapse_query
792 #
793 # Recursively collapse the query, accumulating values for each column.
794
795 sub _collapse_query {
796   my ($self, $query, $collapsed) = @_;
797
798   $collapsed ||= {};
799
800   if (ref $query eq 'ARRAY') {
801     foreach my $subquery (@$query) {
802       next unless ref $subquery;  # -or
803       $collapsed = $self->_collapse_query($subquery, $collapsed);
804     }
805   }
806   elsif (ref $query eq 'HASH') {
807     if (keys %$query and (keys %$query)[0] eq '-and') {
808       foreach my $subquery (@{$query->{-and}}) {
809         $collapsed = $self->_collapse_query($subquery, $collapsed);
810       }
811     }
812     else {
813       foreach my $col (keys %$query) {
814         my $value = $query->{$col};
815         $collapsed->{$col}{$value}++;
816       }
817     }
818   }
819
820   return $collapsed;
821 }
822
823 =head2 get_column
824
825 =over 4
826
827 =item Arguments: $cond?
828
829 =item Return Value: $resultsetcolumn
830
831 =back
832
833   my $max_length = $rs->get_column('length')->max;
834
835 Returns a L<DBIx::Class::ResultSetColumn> instance for a column of the ResultSet.
836
837 =cut
838
839 sub get_column {
840   my ($self, $column) = @_;
841   my $new = DBIx::Class::ResultSetColumn->new($self, $column);
842   return $new;
843 }
844
845 =head2 search_like
846
847 =over 4
848
849 =item Arguments: $cond, \%attrs?
850
851 =item Return Value: $resultset (scalar context), @row_objs (list context)
852
853 =back
854
855   # WHERE title LIKE '%blue%'
856   $cd_rs = $rs->search_like({ title => '%blue%'});
857
858 Performs a search, but uses C<LIKE> instead of C<=> as the condition. Note
859 that this is simply a convenience method retained for ex Class::DBI users.
860 You most likely want to use L</search> with specific operators.
861
862 For more information, see L<DBIx::Class::Manual::Cookbook>.
863
864 This method is deprecated and will be removed in 0.09. Use L</search()>
865 instead. An example conversion is:
866
867   ->search_like({ foo => 'bar' });
868
869   # Becomes
870
871   ->search({ foo => { like => 'bar' } });
872
873 =cut
874
875 sub search_like {
876   my $class = shift;
877   carp (
878     'search_like() is deprecated and will be removed in DBIC version 0.09.'
879    .' Instead use ->search({ x => { -like => "y%" } })'
880    .' (note the outer pair of {}s - they are important!)'
881   );
882   my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
883   my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_};
884   $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
885   return $class->search($query, { %$attrs });
886 }
887
888 =head2 slice
889
890 =over 4
891
892 =item Arguments: $first, $last
893
894 =item Return Value: $resultset (scalar context), @row_objs (list context)
895
896 =back
897
898 Returns a resultset or object list representing a subset of elements from the
899 resultset slice is called on. Indexes are from 0, i.e., to get the first
900 three records, call:
901
902   my ($one, $two, $three) = $rs->slice(0, 2);
903
904 =cut
905
906 sub slice {
907   my ($self, $min, $max) = @_;
908   my $attrs = {}; # = { %{ $self->{attrs} || {} } };
909   $attrs->{offset} = $self->{attrs}{offset} || 0;
910   $attrs->{offset} += $min;
911   $attrs->{rows} = ($max ? ($max - $min + 1) : 1);
912   return $self->search(undef, $attrs);
913   #my $slice = (ref $self)->new($self->result_source, $attrs);
914   #return (wantarray ? $slice->all : $slice);
915 }
916
917 =head2 next
918
919 =over 4
920
921 =item Arguments: none
922
923 =item Return Value: $result | undef
924
925 =back
926
927 Returns the next element in the resultset (C<undef> is there is none).
928
929 Can be used to efficiently iterate over records in the resultset:
930
931   my $rs = $schema->resultset('CD')->search;
932   while (my $cd = $rs->next) {
933     print $cd->title;
934   }
935
936 Note that you need to store the resultset object, and call C<next> on it.
937 Calling C<< resultset('Table')->next >> repeatedly will always return the
938 first record from the resultset.
939
940 =cut
941
942 sub next {
943   my ($self) = @_;
944   if (my $cache = $self->get_cache) {
945     $self->{all_cache_position} ||= 0;
946     return $cache->[$self->{all_cache_position}++];
947   }
948   if ($self->{attrs}{cache}) {
949     delete $self->{pager};
950     $self->{all_cache_position} = 1;
951     return ($self->all)[0];
952   }
953   if ($self->{stashed_objects}) {
954     my $obj = shift(@{$self->{stashed_objects}});
955     delete $self->{stashed_objects} unless @{$self->{stashed_objects}};
956     return $obj;
957   }
958   my @row = (
959     exists $self->{stashed_row}
960       ? @{delete $self->{stashed_row}}
961       : $self->cursor->next
962   );
963   return undef unless (@row);
964   my ($row, @more) = $self->_construct_object(@row);
965   $self->{stashed_objects} = \@more if @more;
966   return $row;
967 }
968
969 sub _construct_object {
970   my ($self, @row) = @_;
971
972   my $info = $self->_collapse_result($self->{_attrs}{as}, \@row)
973     or return ();
974   my @new = $self->result_class->inflate_result($self->result_source, @$info);
975   @new = $self->{_attrs}{record_filter}->(@new)
976     if exists $self->{_attrs}{record_filter};
977   return @new;
978 }
979
980 sub _collapse_result {
981   my ($self, $as_proto, $row) = @_;
982
983   my @copy = @$row;
984
985   # 'foo'         => [ undef, 'foo' ]
986   # 'foo.bar'     => [ 'foo', 'bar' ]
987   # 'foo.bar.baz' => [ 'foo.bar', 'baz' ]
988
989   my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto;
990
991   my %collapse = %{$self->{_attrs}{collapse}||{}};
992
993   my @pri_index;
994
995   # if we're doing collapsing (has_many prefetch) we need to grab records
996   # until the PK changes, so fill @pri_index. if not, we leave it empty so
997   # we know we don't have to bother.
998
999   # the reason for not using the collapse stuff directly is because if you
1000   # had for e.g. two artists in a row with no cds, the collapse info for
1001   # both would be NULL (undef) so you'd lose the second artist
1002
1003   # store just the index so we can check the array positions from the row
1004   # without having to contruct the full hash
1005
1006   if (keys %collapse) {
1007     my %pri = map { ($_ => 1) } $self->result_source->_pri_cols;
1008     foreach my $i (0 .. $#construct_as) {
1009       next if defined($construct_as[$i][0]); # only self table
1010       if (delete $pri{$construct_as[$i][1]}) {
1011         push(@pri_index, $i);
1012       }
1013       last unless keys %pri; # short circuit (Johnny Five Is Alive!)
1014     }
1015   }
1016
1017   # no need to do an if, it'll be empty if @pri_index is empty anyway
1018
1019   my %pri_vals = map { ($_ => $copy[$_]) } @pri_index;
1020
1021   my @const_rows;
1022
1023   do { # no need to check anything at the front, we always want the first row
1024
1025     my %const;
1026
1027     foreach my $this_as (@construct_as) {
1028       $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy);
1029     }
1030
1031     push(@const_rows, \%const);
1032
1033   } until ( # no pri_index => no collapse => drop straight out
1034       !@pri_index
1035     or
1036       do { # get another row, stash it, drop out if different PK
1037
1038         @copy = $self->cursor->next;
1039         $self->{stashed_row} = \@copy;
1040
1041         # last thing in do block, counts as true if anything doesn't match
1042
1043         # check xor defined first for NULL vs. NOT NULL then if one is
1044         # defined the other must be so check string equality
1045
1046         grep {
1047           (defined $pri_vals{$_} ^ defined $copy[$_])
1048           || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_]))
1049         } @pri_index;
1050       }
1051   );
1052
1053   my $alias = $self->{attrs}{alias};
1054   my $info = [];
1055
1056   my %collapse_pos;
1057
1058   my @const_keys;
1059
1060   foreach my $const (@const_rows) {
1061     scalar @const_keys or do {
1062       @const_keys = sort { length($a) <=> length($b) } keys %$const;
1063     };
1064     foreach my $key (@const_keys) {
1065       if (length $key) {
1066         my $target = $info;
1067         my @parts = split(/\./, $key);
1068         my $cur = '';
1069         my $data = $const->{$key};
1070         foreach my $p (@parts) {
1071           $target = $target->[1]->{$p} ||= [];
1072           $cur .= ".${p}";
1073           if ($cur eq ".${key}" && (my @ckey = @{$collapse{$cur}||[]})) {
1074             # collapsing at this point and on final part
1075             my $pos = $collapse_pos{$cur};
1076             CK: foreach my $ck (@ckey) {
1077               if (!defined $pos->{$ck} || $pos->{$ck} ne $data->{$ck}) {
1078                 $collapse_pos{$cur} = $data;
1079                 delete @collapse_pos{ # clear all positioning for sub-entries
1080                   grep { m/^\Q${cur}.\E/ } keys %collapse_pos
1081                 };
1082                 push(@$target, []);
1083                 last CK;
1084               }
1085             }
1086           }
1087           if (exists $collapse{$cur}) {
1088             $target = $target->[-1];
1089           }
1090         }
1091         $target->[0] = $data;
1092       } else {
1093         $info->[0] = $const->{$key};
1094       }
1095     }
1096   }
1097
1098   return $info;
1099 }
1100
1101 =head2 result_source
1102
1103 =over 4
1104
1105 =item Arguments: $result_source?
1106
1107 =item Return Value: $result_source
1108
1109 =back
1110
1111 An accessor for the primary ResultSource object from which this ResultSet
1112 is derived.
1113
1114 =head2 result_class
1115
1116 =over 4
1117
1118 =item Arguments: $result_class?
1119
1120 =item Return Value: $result_class
1121
1122 =back
1123
1124 An accessor for the class to use when creating row objects. Defaults to
1125 C<< result_source->result_class >> - which in most cases is the name of the
1126 L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class.
1127
1128 Note that changing the result_class will also remove any components
1129 that were originally loaded in the source class via
1130 L<DBIx::Class::ResultSource/load_components>. Any overloaded methods
1131 in the original source class will not run.
1132
1133 =cut
1134
1135 sub result_class {
1136   my ($self, $result_class) = @_;
1137   if ($result_class) {
1138     unless (ref $result_class) { # don't fire this for an object
1139       $self->ensure_class_loaded($result_class);
1140     }
1141     $self->_result_class($result_class);
1142     # THIS LINE WOULD BE A BUG - this accessor specifically exists to
1143     # permit the user to set result class on one result set only; it only
1144     # chains if provided to search()
1145     #$self->{attrs}{result_class} = $result_class if ref $self;
1146   }
1147   $self->_result_class;
1148 }
1149
1150 =head2 count
1151
1152 =over 4
1153
1154 =item Arguments: $cond, \%attrs??
1155
1156 =item Return Value: $count
1157
1158 =back
1159
1160 Performs an SQL C<COUNT> with the same query as the resultset was built
1161 with to find the number of elements. Passing arguments is equivalent to
1162 C<< $rs->search ($cond, \%attrs)->count >>
1163
1164 =cut
1165
1166 sub count {
1167   my $self = shift;
1168   return $self->search(@_)->count if @_ and defined $_[0];
1169   return scalar @{ $self->get_cache } if $self->get_cache;
1170
1171   my $attrs = $self->_resolved_attrs_copy;
1172
1173   # this is a little optimization - it is faster to do the limit
1174   # adjustments in software, instead of a subquery
1175   my $rows = delete $attrs->{rows};
1176   my $offset = delete $attrs->{offset};
1177
1178   my $crs;
1179   if ($self->_has_resolved_attr (qw/collapse group_by/)) {
1180     $crs = $self->_count_subq_rs ($attrs);
1181   }
1182   else {
1183     $crs = $self->_count_rs ($attrs);
1184   }
1185   my $count = $crs->next;
1186
1187   $count -= $offset if $offset;
1188   $count = $rows if $rows and $rows < $count;
1189   $count = 0 if ($count < 0);
1190
1191   return $count;
1192 }
1193
1194 =head2 count_rs
1195
1196 =over 4
1197
1198 =item Arguments: $cond, \%attrs??
1199
1200 =item Return Value: $count_rs
1201
1202 =back
1203
1204 Same as L</count> but returns a L<DBIx::Class::ResultSetColumn> object.
1205 This can be very handy for subqueries:
1206
1207   ->search( { amount => $some_rs->count_rs->as_query } )
1208
1209 As with regular resultsets the SQL query will be executed only after
1210 the resultset is accessed via L</next> or L</all>. That would return
1211 the same single value obtainable via L</count>.
1212
1213 =cut
1214
1215 sub count_rs {
1216   my $self = shift;
1217   return $self->search(@_)->count_rs if @_;
1218
1219   # this may look like a lack of abstraction (count() does about the same)
1220   # but in fact an _rs *must* use a subquery for the limits, as the
1221   # software based limiting can not be ported if this $rs is to be used
1222   # in a subquery itself (i.e. ->as_query)
1223   if ($self->_has_resolved_attr (qw/collapse group_by offset rows/)) {
1224     return $self->_count_subq_rs;
1225   }
1226   else {
1227     return $self->_count_rs;
1228   }
1229 }
1230
1231 #
1232 # returns a ResultSetColumn object tied to the count query
1233 #
1234 sub _count_rs {
1235   my ($self, $attrs) = @_;
1236
1237   my $rsrc = $self->result_source;
1238   $attrs ||= $self->_resolved_attrs;
1239
1240   my $tmp_attrs = { %$attrs };
1241   # take off any limits, record_filter is cdbi, and no point of ordering nor locking a count
1242   delete @{$tmp_attrs}{qw/rows offset order_by record_filter for/};
1243
1244   # overwrite the selector (supplied by the storage)
1245   $tmp_attrs->{select} = $rsrc->storage->_count_select ($rsrc, $attrs);
1246   $tmp_attrs->{as} = 'count';
1247
1248   my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count');
1249
1250   return $tmp_rs;
1251 }
1252
1253 #
1254 # same as above but uses a subquery
1255 #
1256 sub _count_subq_rs {
1257   my ($self, $attrs) = @_;
1258
1259   my $rsrc = $self->result_source;
1260   $attrs ||= $self->_resolved_attrs;
1261
1262   my $sub_attrs = { %$attrs };
1263   # extra selectors do not go in the subquery and there is no point of ordering it, nor locking it
1264   delete @{$sub_attrs}{qw/collapse select _prefetch_select as order_by for/};
1265
1266   # if we multi-prefetch we group_by primary keys only as this is what we would
1267   # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless
1268   if ( keys %{$attrs->{collapse}}  ) {
1269     $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } ($rsrc->_pri_cols) ]
1270   }
1271
1272   # Calculate subquery selector
1273   if (my $g = $sub_attrs->{group_by}) {
1274
1275     my $sql_maker = $rsrc->storage->sql_maker;
1276
1277     # necessary as the group_by may refer to aliased functions
1278     my $sel_index;
1279     for my $sel (@{$attrs->{select}}) {
1280       $sel_index->{$sel->{-as}} = $sel
1281         if (ref $sel eq 'HASH' and $sel->{-as});
1282     }
1283
1284     for my $g_part (@$g) {
1285       my $colpiece = $sel_index->{$g_part} || $g_part;
1286
1287       # disqualify join-based group_by's. Arcane but possible query
1288       # also horrible horrible hack to alias a column (not a func.)
1289       # (probably need to introduce SQLA syntax)
1290       if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) {
1291         my $as = $colpiece;
1292         $as =~ s/\./__/;
1293         $colpiece = \ sprintf ('%s AS %s', map { $sql_maker->_quote ($_) } ($colpiece, $as) );
1294       }
1295       push @{$sub_attrs->{select}}, $colpiece;
1296     }
1297   }
1298   else {
1299     my @pcols = map { "$attrs->{alias}.$_" } ($rsrc->primary_columns);
1300     $sub_attrs->{select} = @pcols ? \@pcols : [ 1 ];
1301   }
1302
1303   return $rsrc->resultset_class
1304                ->new ($rsrc, $sub_attrs)
1305                 ->as_subselect_rs
1306                  ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } })
1307                   ->get_column ('count');
1308 }
1309
1310 sub _bool {
1311   return 1;
1312 }
1313
1314 =head2 count_literal
1315
1316 =over 4
1317
1318 =item Arguments: $sql_fragment, @bind_values
1319
1320 =item Return Value: $count
1321
1322 =back
1323
1324 Counts the results in a literal query. Equivalent to calling L</search_literal>
1325 with the passed arguments, then L</count>.
1326
1327 =cut
1328
1329 sub count_literal { shift->search_literal(@_)->count; }
1330
1331 =head2 all
1332
1333 =over 4
1334
1335 =item Arguments: none
1336
1337 =item Return Value: @objects
1338
1339 =back
1340
1341 Returns all elements in the resultset. Called implicitly if the resultset
1342 is returned in list context.
1343
1344 =cut
1345
1346 sub all {
1347   my $self = shift;
1348   if(@_) {
1349       $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
1350   }
1351
1352   return @{ $self->get_cache } if $self->get_cache;
1353
1354   my @obj;
1355
1356   if (keys %{$self->_resolved_attrs->{collapse}}) {
1357     # Using $self->cursor->all is really just an optimisation.
1358     # If we're collapsing has_many prefetches it probably makes
1359     # very little difference, and this is cleaner than hacking
1360     # _construct_object to survive the approach
1361     $self->cursor->reset;
1362     my @row = $self->cursor->next;
1363     while (@row) {
1364       push(@obj, $self->_construct_object(@row));
1365       @row = (exists $self->{stashed_row}
1366                ? @{delete $self->{stashed_row}}
1367                : $self->cursor->next);
1368     }
1369   } else {
1370     @obj = map { $self->_construct_object(@$_) } $self->cursor->all;
1371   }
1372
1373   $self->set_cache(\@obj) if $self->{attrs}{cache};
1374
1375   return @obj;
1376 }
1377
1378 =head2 reset
1379
1380 =over 4
1381
1382 =item Arguments: none
1383
1384 =item Return Value: $self
1385
1386 =back
1387
1388 Resets the resultset's cursor, so you can iterate through the elements again.
1389 Implicitly resets the storage cursor, so a subsequent L</next> will trigger
1390 another query.
1391
1392 =cut
1393
1394 sub reset {
1395   my ($self) = @_;
1396   delete $self->{_attrs} if exists $self->{_attrs};
1397   $self->{all_cache_position} = 0;
1398   $self->cursor->reset;
1399   return $self;
1400 }
1401
1402 =head2 first
1403
1404 =over 4
1405
1406 =item Arguments: none
1407
1408 =item Return Value: $object | undef
1409
1410 =back
1411
1412 Resets the resultset and returns an object for the first result (or C<undef>
1413 if the resultset is empty).
1414
1415 =cut
1416
1417 sub first {
1418   return $_[0]->reset->next;
1419 }
1420
1421
1422 # _rs_update_delete
1423 #
1424 # Determines whether and what type of subquery is required for the $rs operation.
1425 # If grouping is necessary either supplies its own, or verifies the current one
1426 # After all is done delegates to the proper storage method.
1427
1428 sub _rs_update_delete {
1429   my ($self, $op, $values) = @_;
1430
1431   my $rsrc = $self->result_source;
1432
1433   # if a condition exists we need to strip all table qualifiers
1434   # if this is not possible we'll force a subquery below
1435   my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond});
1436
1437   my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/);
1438   my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/rows offset/);
1439
1440   if ($needs_group_by_subq or $needs_subq) {
1441
1442     # make a new $rs selecting only the PKs (that's all we really need)
1443     my $attrs = $self->_resolved_attrs_copy;
1444
1445
1446     delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_select as/;
1447     $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ];
1448
1449     if ($needs_group_by_subq) {
1450       # make sure no group_by was supplied, or if there is one - make sure it matches
1451       # the columns compiled above perfectly. Anything else can not be sanely executed
1452       # on most databases so croak right then and there
1453
1454       if (my $g = $attrs->{group_by}) {
1455         my @current_group_by = map
1456           { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
1457           @$g
1458         ;
1459
1460         if (
1461           join ("\x00", sort @current_group_by)
1462             ne
1463           join ("\x00", sort @{$attrs->{columns}} )
1464         ) {
1465           $self->throw_exception (
1466             "You have just attempted a $op operation on a resultset which does group_by"
1467             . ' on columns other than the primary keys, while DBIC internally needs to retrieve'
1468             . ' the primary keys in a subselect. All sane RDBMS engines do not support this'
1469             . ' kind of queries. Please retry the operation with a modified group_by or'
1470             . ' without using one at all.'
1471           );
1472         }
1473       }
1474       else {
1475         $attrs->{group_by} = $attrs->{columns};
1476       }
1477     }
1478
1479     my $subrs = (ref $self)->new($rsrc, $attrs);
1480     return $self->result_source->storage->_subq_update_delete($subrs, $op, $values);
1481   }
1482   else {
1483     return $rsrc->storage->$op(
1484       $rsrc,
1485       $op eq 'update' ? $values : (),
1486       $cond,
1487     );
1488   }
1489 }
1490
1491 =head2 update
1492
1493 =over 4
1494
1495 =item Arguments: \%values
1496
1497 =item Return Value: $storage_rv
1498
1499 =back
1500
1501 Sets the specified columns in the resultset to the supplied values in a
1502 single query. Note that this will not run any accessor/set_column/update
1503 triggers, nor will it update any row object instances derived from this
1504 resultset (this includes the contents of the L<resultset cache|/set_cache>
1505 if any). See L</update_all> if you need to execute any on-update
1506 triggers or cascades defined either by you or a
1507 L<result component|DBIx::Class::Manual::Component/WHAT_IS_A_COMPONENT>.
1508
1509 The return value is a pass through of what the underlying
1510 storage backend returned, and may vary. See L<DBI/execute> for the most
1511 common case.
1512
1513 =cut
1514
1515 sub update {
1516   my ($self, $values) = @_;
1517   $self->throw_exception('Values for update must be a hash')
1518     unless ref $values eq 'HASH';
1519
1520   return $self->_rs_update_delete ('update', $values);
1521 }
1522
1523 =head2 update_all
1524
1525 =over 4
1526
1527 =item Arguments: \%values
1528
1529 =item Return Value: 1
1530
1531 =back
1532
1533 Fetches all objects and updates them one at a time via
1534 L<DBIx::Class::Row/update>. Note that C<update_all> will run DBIC defined
1535 triggers, while L</update> will not.
1536
1537 =cut
1538
1539 sub update_all {
1540   my ($self, $values) = @_;
1541   $self->throw_exception('Values for update_all must be a hash')
1542     unless ref $values eq 'HASH';
1543
1544   my $guard = $self->result_source->schema->txn_scope_guard;
1545   $_->update($values) for $self->all;
1546   $guard->commit;
1547   return 1;
1548 }
1549
1550 =head2 delete
1551
1552 =over 4
1553
1554 =item Arguments: none
1555
1556 =item Return Value: $storage_rv
1557
1558 =back
1559
1560 Deletes the rows matching this resultset in a single query. Note that this
1561 will not run any delete triggers, nor will it alter the
1562 L<in_storage|DBIx::Class::Row/in_storage> status of any row object instances
1563 derived from this resultset (this includes the contents of the
1564 L<resultset cache|/set_cache> if any). See L</delete_all> if you need to
1565 execute any on-delete triggers or cascades defined either by you or a
1566 L<result component|DBIx::Class::Manual::Component/WHAT_IS_A_COMPONENT>.
1567
1568 The return value is a pass through of what the underlying storage backend
1569 returned, and may vary. See L<DBI/execute> for the most common case.
1570
1571 =cut
1572
1573 sub delete {
1574   my $self = shift;
1575   $self->throw_exception('delete does not accept any arguments')
1576     if @_;
1577
1578   return $self->_rs_update_delete ('delete');
1579 }
1580
1581 =head2 delete_all
1582
1583 =over 4
1584
1585 =item Arguments: none
1586
1587 =item Return Value: 1
1588
1589 =back
1590
1591 Fetches all objects and deletes them one at a time via
1592 L<DBIx::Class::Row/delete>. Note that C<delete_all> will run DBIC defined
1593 triggers, while L</delete> will not.
1594
1595 =cut
1596
1597 sub delete_all {
1598   my $self = shift;
1599   $self->throw_exception('delete_all does not accept any arguments')
1600     if @_;
1601
1602   my $guard = $self->result_source->schema->txn_scope_guard;
1603   $_->delete for $self->all;
1604   $guard->commit;
1605   return 1;
1606 }
1607
1608 =head2 populate
1609
1610 =over 4
1611
1612 =item Arguments: \@data;
1613
1614 =back
1615
1616 Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs.
1617 For the arrayref of hashrefs style each hashref should be a structure suitable
1618 forsubmitting to a $resultset->create(...) method.
1619
1620 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
1621 to insert the data, as this is a faster method.
1622
1623 Otherwise, each set of data is inserted into the database using
1624 L<DBIx::Class::ResultSet/create>, and the resulting objects are
1625 accumulated into an array. The array itself, or an array reference
1626 is returned depending on scalar or list context.
1627
1628 Example:  Assuming an Artist Class that has many CDs Classes relating:
1629
1630   my $Artist_rs = $schema->resultset("Artist");
1631
1632   ## Void Context Example
1633   $Artist_rs->populate([
1634      { artistid => 4, name => 'Manufactured Crap', cds => [
1635         { title => 'My First CD', year => 2006 },
1636         { title => 'Yet More Tweeny-Pop crap', year => 2007 },
1637       ],
1638      },
1639      { artistid => 5, name => 'Angsty-Whiny Girl', cds => [
1640         { title => 'My parents sold me to a record company', year => 2005 },
1641         { title => 'Why Am I So Ugly?', year => 2006 },
1642         { title => 'I Got Surgery and am now Popular', year => 2007 }
1643       ],
1644      },
1645   ]);
1646
1647   ## Array Context Example
1648   my ($ArtistOne, $ArtistTwo, $ArtistThree) = $Artist_rs->populate([
1649     { name => "Artist One"},
1650     { name => "Artist Two"},
1651     { name => "Artist Three", cds=> [
1652     { title => "First CD", year => 2007},
1653     { title => "Second CD", year => 2008},
1654   ]}
1655   ]);
1656
1657   print $ArtistOne->name; ## response is 'Artist One'
1658   print $ArtistThree->cds->count ## reponse is '2'
1659
1660 For the arrayref of arrayrefs style,  the first element should be a list of the
1661 fieldsnames to which the remaining elements are rows being inserted.  For
1662 example:
1663
1664   $Arstist_rs->populate([
1665     [qw/artistid name/],
1666     [100, 'A Formally Unknown Singer'],
1667     [101, 'A singer that jumped the shark two albums ago'],
1668     [102, 'An actually cool singer'],
1669   ]);
1670
1671 Please note an important effect on your data when choosing between void and
1672 wantarray context. Since void context goes straight to C<insert_bulk> in
1673 L<DBIx::Class::Storage::DBI> this will skip any component that is overriding
1674 C<insert>.  So if you are using something like L<DBIx-Class-UUIDColumns> to
1675 create primary keys for you, you will find that your PKs are empty.  In this
1676 case you will have to use the wantarray context in order to create those
1677 values.
1678
1679 =cut
1680
1681 sub populate {
1682   my $self = shift;
1683
1684   # cruft placed in standalone method
1685   my $data = $self->_normalize_populate_args(@_);
1686
1687   if(defined wantarray) {
1688     my @created;
1689     foreach my $item (@$data) {
1690       push(@created, $self->create($item));
1691     }
1692     return wantarray ? @created : \@created;
1693   } else {
1694     my $first = $data->[0];
1695
1696     # if a column is a registered relationship, and is a non-blessed hash/array, consider
1697     # it relationship data
1698     my (@rels, @columns);
1699     for (keys %$first) {
1700       my $ref = ref $first->{$_};
1701       $self->result_source->has_relationship($_) && ($ref eq 'ARRAY' or $ref eq 'HASH')
1702         ? push @rels, $_
1703         : push @columns, $_
1704       ;
1705     }
1706
1707     my @pks = $self->result_source->primary_columns;
1708
1709     ## do the belongs_to relationships
1710     foreach my $index (0..$#$data) {
1711
1712       # delegate to create() for any dataset without primary keys with specified relationships
1713       if (grep { !defined $data->[$index]->{$_} } @pks ) {
1714         for my $r (@rels) {
1715           if (grep { ref $data->[$index]{$r} eq $_ } qw/HASH ARRAY/) {  # a related set must be a HASH or AoH
1716             my @ret = $self->populate($data);
1717             return;
1718           }
1719         }
1720       }
1721
1722       foreach my $rel (@rels) {
1723         next unless ref $data->[$index]->{$rel} eq "HASH";
1724         my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel});
1725         my ($reverse) = keys %{$self->result_source->reverse_relationship_info($rel)};
1726         my $related = $result->result_source->_resolve_condition(
1727           $result->result_source->relationship_info($reverse)->{cond},
1728           $self,
1729           $result,
1730         );
1731
1732         delete $data->[$index]->{$rel};
1733         $data->[$index] = {%{$data->[$index]}, %$related};
1734
1735         push @columns, keys %$related if $index == 0;
1736       }
1737     }
1738
1739     ## inherit the data locked in the conditions of the resultset
1740     my ($rs_data) = $self->_merge_with_rscond({});
1741     delete @{$rs_data}{@columns};
1742     my @inherit_cols = keys %$rs_data;
1743     my @inherit_data = values %$rs_data;
1744
1745     ## do bulk insert on current row
1746     $self->result_source->storage->insert_bulk(
1747       $self->result_source,
1748       [@columns, @inherit_cols],
1749       [ map { [ @$_{@columns}, @inherit_data ] } @$data ],
1750     );
1751
1752     ## do the has_many relationships
1753     foreach my $item (@$data) {
1754
1755       foreach my $rel (@rels) {
1756         next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY";
1757
1758         my $parent = $self->find({map { $_ => $item->{$_} } @pks})
1759      || $self->throw_exception('Cannot find the relating object.');
1760
1761         my $child = $parent->$rel;
1762
1763         my $related = $child->result_source->_resolve_condition(
1764           $parent->result_source->relationship_info($rel)->{cond},
1765           $child,
1766           $parent,
1767         );
1768
1769         my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
1770         my @populate = map { {%$_, %$related} } @rows_to_add;
1771
1772         $child->populate( \@populate );
1773       }
1774     }
1775   }
1776 }
1777
1778
1779 # populate() argumnets went over several incarnations
1780 # What we ultimately support is AoH
1781 sub _normalize_populate_args {
1782   my ($self, $arg) = @_;
1783
1784   if (ref $arg eq 'ARRAY') {
1785     if (ref $arg->[0] eq 'HASH') {
1786       return $arg;
1787     }
1788     elsif (ref $arg->[0] eq 'ARRAY') {
1789       my @ret;
1790       my @colnames = @{$arg->[0]};
1791       foreach my $values (@{$arg}[1 .. $#$arg]) {
1792         push @ret, { map { $colnames[$_] => $values->[$_] } (0 .. $#colnames) };
1793       }
1794       return \@ret;
1795     }
1796   }
1797
1798   $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs');
1799 }
1800
1801 =head2 pager
1802
1803 =over 4
1804
1805 =item Arguments: none
1806
1807 =item Return Value: $pager
1808
1809 =back
1810
1811 Return Value a L<Data::Page> object for the current resultset. Only makes
1812 sense for queries with a C<page> attribute.
1813
1814 To get the full count of entries for a paged resultset, call
1815 C<total_entries> on the L<Data::Page> object.
1816
1817 =cut
1818
1819 # make a wizard good for both a scalar and a hashref
1820 my $mk_lazy_count_wizard = sub {
1821   require Variable::Magic;
1822
1823   my $stash = { total_rs => shift };
1824   my $slot = shift; # only used by the hashref magic
1825
1826   my $magic = Variable::Magic::wizard (
1827     data => sub { $stash },
1828
1829     (!$slot)
1830     ? (
1831       # the scalar magic
1832       get => sub {
1833         # set value lazily, and dispell for good
1834         ${$_[0]} = $_[1]{total_rs}->count;
1835         Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref});
1836         return 1;
1837       },
1838       set => sub {
1839         # an explicit set implies dispell as well
1840         # the unless() is to work around "fun and giggles" below
1841         Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref})
1842           unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
1843         return 1;
1844       },
1845     )
1846     : (
1847       # the uvar magic
1848       fetch => sub {
1849         if ($_[2] eq $slot and !$_[1]{inactive}) {
1850           my $cnt = $_[1]{total_rs}->count;
1851           $_[0]->{$slot} = $cnt;
1852
1853           # attempting to dispell in a fetch handle (works in store), seems
1854           # to invariable segfault on 5.10, 5.12, 5.13 :(
1855           # so use an inactivator instead
1856           #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
1857           $_[1]{inactive}++;
1858         }
1859         return 1;
1860       },
1861       store => sub {
1862         if (! $_[1]{inactive} and $_[2] eq $slot) {
1863           #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
1864           $_[1]{inactive}++
1865             unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
1866         }
1867         return 1;
1868       },
1869     ),
1870   );
1871
1872   $stash->{magic_selfref} = $magic;
1873   weaken ($stash->{magic_selfref}); # this fails on 5.8.1
1874
1875   return $magic;
1876 };
1877
1878 # the tie class for 5.8.1
1879 {
1880   package # hide from pause
1881     DBIx::Class::__DBIC_LAZY_RS_COUNT__;
1882   use base qw/Tie::Hash/;
1883
1884   sub FIRSTKEY { my $dummy = scalar keys %{$_[0]{data}}; each %{$_[0]{data}} }
1885   sub NEXTKEY  { each %{$_[0]{data}} }
1886   sub EXISTS   { exists $_[0]{data}{$_[1]} }
1887   sub DELETE   { delete $_[0]{data}{$_[1]} }
1888   sub CLEAR    { %{$_[0]{data}} = () }
1889   sub SCALAR   { scalar %{$_[0]{data}} }
1890
1891   sub TIEHASH {
1892     $_[1]{data} = {%{$_[1]{selfref}}};
1893     %{$_[1]{selfref}} = ();
1894     Scalar::Util::weaken ($_[1]{selfref});
1895     return bless ($_[1], $_[0]);
1896   };
1897
1898   sub FETCH {
1899     if ($_[1] eq $_[0]{slot}) {
1900       my $cnt = $_[0]{data}{$_[1]} = $_[0]{total_rs}->count;
1901       untie %{$_[0]{selfref}};
1902       %{$_[0]{selfref}} = %{$_[0]{data}};
1903       return $cnt;
1904     }
1905     else {
1906       $_[0]{data}{$_[1]};
1907     }
1908   }
1909
1910   sub STORE {
1911     $_[0]{data}{$_[1]} = $_[2];
1912     if ($_[1] eq $_[0]{slot}) {
1913       untie %{$_[0]{selfref}};
1914       %{$_[0]{selfref}} = %{$_[0]{data}};
1915     }
1916     $_[2];
1917   }
1918 }
1919
1920 sub pager {
1921   my ($self) = @_;
1922
1923   return $self->{pager} if $self->{pager};
1924
1925   if ($self->get_cache) {
1926     $self->throw_exception ('Pagers on cached resultsets are not supported');
1927   }
1928
1929   my $attrs = $self->{attrs};
1930   $self->throw_exception("Can't create pager for non-paged rs")
1931     unless $self->{attrs}{page};
1932   $attrs->{rows} ||= 10;
1933
1934   # throw away the paging flags and re-run the count (possibly
1935   # with a subselect) to get the real total count
1936   my $count_attrs = { %$attrs };
1937   delete $count_attrs->{$_} for qw/rows offset page pager/;
1938   my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
1939
1940
1941 ### the following may seem awkward and dirty, but it's a thought-experiment
1942 ### necessary for future development of DBIx::DS. Do *NOT* change this code
1943 ### before talking to ribasushi/mst
1944
1945   my $pager = Data::Page->new(
1946     0,  #start with an empty set
1947     $attrs->{rows},
1948     $self->{attrs}{page},
1949   );
1950
1951   my $data_slot = 'total_entries';
1952
1953   # Since we are interested in a cached value (once it's set - it's set), every
1954   # technique will detach from the magic-host once the time comes to fire the
1955   # ->count (or in the segfaulting case of >= 5.10 it will deactivate itself)
1956
1957   if ($] < 5.008003) {
1958     # 5.8.1 throws 'Modification of a read-only value attempted' when one tries
1959     # to weakref the magic container :(
1960     # tested on 5.8.1
1961     tie (%$pager, 'DBIx::Class::__DBIC_LAZY_RS_COUNT__',
1962       { slot => $data_slot, total_rs => $total_rs, selfref => $pager }
1963     );
1964   }
1965   elsif ($] < 5.010) {
1966     # We can use magic on the hash value slot. It's interesting that the magic is
1967     # attached to the hash-slot, and does *not* stop working once I do the dummy
1968     # assignments after the cast()
1969     # tested on 5.8.3 and 5.8.9
1970     my $magic = $mk_lazy_count_wizard->($total_rs);
1971     Variable::Magic::cast ( $pager->{$data_slot}, $magic );
1972
1973     # this is for fun and giggles
1974     $pager->{$data_slot} = -1;
1975     $pager->{$data_slot} = 0;
1976
1977     # this does not work for scalars, but works with
1978     # uvar magic below
1979     #my %vals = %$pager;
1980     #%$pager = ();
1981     #%{$pager} = %vals;
1982   }
1983   else {
1984     # And the uvar magic
1985     # works on 5.10.1, 5.12.1 and 5.13.4 in its current form,
1986     # however see the wizard maker for more notes
1987     my $magic = $mk_lazy_count_wizard->($total_rs, $data_slot);
1988     Variable::Magic::cast ( %$pager, $magic );
1989
1990     # still works
1991     $pager->{$data_slot} = -1;
1992     $pager->{$data_slot} = 0;
1993
1994     # this now works
1995     my %vals = %$pager;
1996     %$pager = ();
1997     %{$pager} = %vals;
1998   }
1999
2000   return $self->{pager} = $pager;
2001 }
2002
2003 =head2 page
2004
2005 =over 4
2006
2007 =item Arguments: $page_number
2008
2009 =item Return Value: $rs
2010
2011 =back
2012
2013 Returns a resultset for the $page_number page of the resultset on which page
2014 is called, where each page contains a number of rows equal to the 'rows'
2015 attribute set on the resultset (10 by default).
2016
2017 =cut
2018
2019 sub page {
2020   my ($self, $page) = @_;
2021   return (ref $self)->new($self->result_source, { %{$self->{attrs}}, page => $page });
2022 }
2023
2024 =head2 new_result
2025
2026 =over 4
2027
2028 =item Arguments: \%vals
2029
2030 =item Return Value: $rowobject
2031
2032 =back
2033
2034 Creates a new row object in the resultset's result class and returns
2035 it. The row is not inserted into the database at this point, call
2036 L<DBIx::Class::Row/insert> to do that. Calling L<DBIx::Class::Row/in_storage>
2037 will tell you whether the row object has been inserted or not.
2038
2039 Passes the hashref of input on to L<DBIx::Class::Row/new>.
2040
2041 =cut
2042
2043 sub new_result {
2044   my ($self, $values) = @_;
2045   $self->throw_exception( "new_result needs a hash" )
2046     unless (ref $values eq 'HASH');
2047
2048   my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values);
2049
2050   my %new = (
2051     %$merged_cond,
2052     @$cols_from_relations
2053       ? (-cols_from_relations => $cols_from_relations)
2054       : (),
2055     -source_handle => $self->_source_handle,
2056     -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
2057   );
2058
2059   return $self->result_class->new(\%new);
2060 }
2061
2062 # _merge_with_rscond
2063 #
2064 # Takes a simple hash of K/V data and returns its copy merged with the
2065 # condition already present on the resultset. Additionally returns an
2066 # arrayref of value/condition names, which were inferred from related
2067 # objects (this is needed for in-memory related objects)
2068 sub _merge_with_rscond {
2069   my ($self, $data) = @_;
2070
2071   my (%new_data, @cols_from_relations);
2072
2073   my $alias = $self->{attrs}{alias};
2074
2075   if (! defined $self->{cond}) {
2076     # just massage $data below
2077   }
2078   elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
2079     %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
2080     @cols_from_relations = keys %new_data;
2081   }
2082   elsif (ref $self->{cond} ne 'HASH') {
2083     $self->throw_exception(
2084       "Can't abstract implicit construct, resultset condition not a hash"
2085     );
2086   }
2087   else {
2088     # precendence must be given to passed values over values inherited from
2089     # the cond, so the order here is important.
2090     my $collapsed_cond = $self->_collapse_cond($self->{cond});
2091     my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
2092
2093     while ( my($col, $value) = each %implied ) {
2094       my $vref = ref $value;
2095       if ($vref eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') {
2096         $new_data{$col} = $value->{'='};
2097       }
2098       elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) {
2099         $new_data{$col} = $value;
2100       }
2101     }
2102   }
2103
2104   %new_data = (
2105     %new_data,
2106     %{ $self->_remove_alias($data, $alias) },
2107   );
2108
2109   return (\%new_data, \@cols_from_relations);
2110 }
2111
2112 # _has_resolved_attr
2113 #
2114 # determines if the resultset defines at least one
2115 # of the attributes supplied
2116 #
2117 # used to determine if a subquery is neccessary
2118 #
2119 # supports some virtual attributes:
2120 #   -join
2121 #     This will scan for any joins being present on the resultset.
2122 #     It is not a mere key-search but a deep inspection of {from}
2123 #
2124
2125 sub _has_resolved_attr {
2126   my ($self, @attr_names) = @_;
2127
2128   my $attrs = $self->_resolved_attrs;
2129
2130   my %extra_checks;
2131
2132   for my $n (@attr_names) {
2133     if (grep { $n eq $_ } (qw/-join/) ) {
2134       $extra_checks{$n}++;
2135       next;
2136     }
2137
2138     my $attr =  $attrs->{$n};
2139
2140     next if not defined $attr;
2141
2142     if (ref $attr eq 'HASH') {
2143       return 1 if keys %$attr;
2144     }
2145     elsif (ref $attr eq 'ARRAY') {
2146       return 1 if @$attr;
2147     }
2148     else {
2149       return 1 if $attr;
2150     }
2151   }
2152
2153   # a resolved join is expressed as a multi-level from
2154   return 1 if (
2155     $extra_checks{-join}
2156       and
2157     ref $attrs->{from} eq 'ARRAY'
2158       and
2159     @{$attrs->{from}} > 1
2160   );
2161
2162   return 0;
2163 }
2164
2165 # _collapse_cond
2166 #
2167 # Recursively collapse the condition.
2168
2169 sub _collapse_cond {
2170   my ($self, $cond, $collapsed) = @_;
2171
2172   $collapsed ||= {};
2173
2174   if (ref $cond eq 'ARRAY') {
2175     foreach my $subcond (@$cond) {
2176       next unless ref $subcond;  # -or
2177       $collapsed = $self->_collapse_cond($subcond, $collapsed);
2178     }
2179   }
2180   elsif (ref $cond eq 'HASH') {
2181     if (keys %$cond and (keys %$cond)[0] eq '-and') {
2182       foreach my $subcond (@{$cond->{-and}}) {
2183         $collapsed = $self->_collapse_cond($subcond, $collapsed);
2184       }
2185     }
2186     else {
2187       foreach my $col (keys %$cond) {
2188         my $value = $cond->{$col};
2189         $collapsed->{$col} = $value;
2190       }
2191     }
2192   }
2193
2194   return $collapsed;
2195 }
2196
2197 # _remove_alias
2198 #
2199 # Remove the specified alias from the specified query hash. A copy is made so
2200 # the original query is not modified.
2201
2202 sub _remove_alias {
2203   my ($self, $query, $alias) = @_;
2204
2205   my %orig = %{ $query || {} };
2206   my %unaliased;
2207
2208   foreach my $key (keys %orig) {
2209     if ($key !~ /\./) {
2210       $unaliased{$key} = $orig{$key};
2211       next;
2212     }
2213     $unaliased{$1} = $orig{$key}
2214       if $key =~ m/^(?:\Q$alias\E\.)?([^.]+)$/;
2215   }
2216
2217   return \%unaliased;
2218 }
2219
2220 =head2 as_query
2221
2222 =over 4
2223
2224 =item Arguments: none
2225
2226 =item Return Value: \[ $sql, @bind ]
2227
2228 =back
2229
2230 Returns the SQL query and bind vars associated with the invocant.
2231
2232 This is generally used as the RHS for a subquery.
2233
2234 =cut
2235
2236 sub as_query {
2237   my $self = shift;
2238
2239   my $attrs = $self->_resolved_attrs_copy;
2240
2241   # For future use:
2242   #
2243   # in list ctx:
2244   # my ($sql, \@bind, \%dbi_bind_attrs) = _select_args_to_query (...)
2245   # $sql also has no wrapping parenthesis in list ctx
2246   #
2247   my $sqlbind = $self->result_source->storage
2248     ->_select_args_to_query ($attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs);
2249
2250   return $sqlbind;
2251 }
2252
2253 =head2 find_or_new
2254
2255 =over 4
2256
2257 =item Arguments: \%vals, \%attrs?
2258
2259 =item Return Value: $rowobject
2260
2261 =back
2262
2263   my $artist = $schema->resultset('Artist')->find_or_new(
2264     { artist => 'fred' }, { key => 'artists' });
2265
2266   $cd->cd_to_producer->find_or_new({ producer => $producer },
2267                                    { key => 'primary });
2268
2269 Find an existing record from this resultset using L</find>. if none exists,
2270 instantiate a new result object and return it. The object will not be saved
2271 into your storage until you call L<DBIx::Class::Row/insert> on it.
2272
2273 You most likely want this method when looking for existing rows using a unique
2274 constraint that is not the primary key, or looking for related rows.
2275
2276 If you want objects to be saved immediately, use L</find_or_create> instead.
2277
2278 B<Note>: Make sure to read the documentation of L</find> and understand the
2279 significance of the C<key> attribute, as its lack may skew your search, and
2280 subsequently result in spurious new objects.
2281
2282 B<Note>: Take care when using C<find_or_new> with a table having
2283 columns with default values that you intend to be automatically
2284 supplied by the database (e.g. an auto_increment primary key column).
2285 In normal usage, the value of such columns should NOT be included at
2286 all in the call to C<find_or_new>, even when set to C<undef>.
2287
2288 =cut
2289
2290 sub find_or_new {
2291   my $self     = shift;
2292   my $attrs    = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
2293   my $hash     = ref $_[0] eq 'HASH' ? shift : {@_};
2294   if (keys %$hash and my $row = $self->find($hash, $attrs) ) {
2295     return $row;
2296   }
2297   return $self->new_result($hash);
2298 }
2299
2300 =head2 create
2301
2302 =over 4
2303
2304 =item Arguments: \%vals
2305
2306 =item Return Value: a L<DBIx::Class::Row> $object
2307
2308 =back
2309
2310 Attempt to create a single new row or a row with multiple related rows
2311 in the table represented by the resultset (and related tables). This
2312 will not check for duplicate rows before inserting, use
2313 L</find_or_create> to do that.
2314
2315 To create one row for this resultset, pass a hashref of key/value
2316 pairs representing the columns of the table and the values you wish to
2317 store. If the appropriate relationships are set up, foreign key fields
2318 can also be passed an object representing the foreign row, and the
2319 value will be set to its primary key.
2320
2321 To create related objects, pass a hashref of related-object column values
2322 B<keyed on the relationship name>. If the relationship is of type C<multi>
2323 (L<DBIx::Class::Relationship/has_many>) - pass an arrayref of hashrefs.
2324 The process will correctly identify columns holding foreign keys, and will
2325 transparently populate them from the keys of the corresponding relation.
2326 This can be applied recursively, and will work correctly for a structure
2327 with an arbitrary depth and width, as long as the relationships actually
2328 exists and the correct column data has been supplied.
2329
2330
2331 Instead of hashrefs of plain related data (key/value pairs), you may
2332 also pass new or inserted objects. New objects (not inserted yet, see
2333 L</new>), will be inserted into their appropriate tables.
2334
2335 Effectively a shortcut for C<< ->new_result(\%vals)->insert >>.
2336
2337 Example of creating a new row.
2338
2339   $person_rs->create({
2340     name=>"Some Person",
2341     email=>"somebody@someplace.com"
2342   });
2343
2344 Example of creating a new row and also creating rows in a related C<has_many>
2345 or C<has_one> resultset.  Note Arrayref.
2346
2347   $artist_rs->create(
2348      { artistid => 4, name => 'Manufactured Crap', cds => [
2349         { title => 'My First CD', year => 2006 },
2350         { title => 'Yet More Tweeny-Pop crap', year => 2007 },
2351       ],
2352      },
2353   );
2354
2355 Example of creating a new row and also creating a row in a related
2356 C<belongs_to> resultset. Note Hashref.
2357
2358   $cd_rs->create({
2359     title=>"Music for Silly Walks",
2360     year=>2000,
2361     artist => {
2362       name=>"Silly Musician",
2363     }
2364   });
2365
2366 =over
2367
2368 =item WARNING
2369
2370 When subclassing ResultSet never attempt to override this method. Since
2371 it is a simple shortcut for C<< $self->new_result($attrs)->insert >>, a
2372 lot of the internals simply never call it, so your override will be
2373 bypassed more often than not. Override either L<new|DBIx::Class::Row/new>
2374 or L<insert|DBIx::Class::Row/insert> depending on how early in the
2375 L</create> process you need to intervene.
2376
2377 =back
2378
2379 =cut
2380
2381 sub create {
2382   my ($self, $attrs) = @_;
2383   $self->throw_exception( "create needs a hashref" )
2384     unless ref $attrs eq 'HASH';
2385   return $self->new_result($attrs)->insert;
2386 }
2387
2388 =head2 find_or_create
2389
2390 =over 4
2391
2392 =item Arguments: \%vals, \%attrs?
2393
2394 =item Return Value: $rowobject
2395
2396 =back
2397
2398   $cd->cd_to_producer->find_or_create({ producer => $producer },
2399                                       { key => 'primary' });
2400
2401 Tries to find a record based on its primary key or unique constraints; if none
2402 is found, creates one and returns that instead.
2403
2404   my $cd = $schema->resultset('CD')->find_or_create({
2405     cdid   => 5,
2406     artist => 'Massive Attack',
2407     title  => 'Mezzanine',
2408     year   => 2005,
2409   });
2410
2411 Also takes an optional C<key> attribute, to search by a specific key or unique
2412 constraint. For example:
2413
2414   my $cd = $schema->resultset('CD')->find_or_create(
2415     {
2416       artist => 'Massive Attack',
2417       title  => 'Mezzanine',
2418     },
2419     { key => 'cd_artist_title' }
2420   );
2421
2422 B<Note>: Make sure to read the documentation of L</find> and understand the
2423 significance of the C<key> attribute, as its lack may skew your search, and
2424 subsequently result in spurious row creation.
2425
2426 B<Note>: Because find_or_create() reads from the database and then
2427 possibly inserts based on the result, this method is subject to a race
2428 condition. Another process could create a record in the table after
2429 the find has completed and before the create has started. To avoid
2430 this problem, use find_or_create() inside a transaction.
2431
2432 B<Note>: Take care when using C<find_or_create> with a table having
2433 columns with default values that you intend to be automatically
2434 supplied by the database (e.g. an auto_increment primary key column).
2435 In normal usage, the value of such columns should NOT be included at
2436 all in the call to C<find_or_create>, even when set to C<undef>.
2437
2438 See also L</find> and L</update_or_create>. For information on how to declare
2439 unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
2440
2441 =cut
2442
2443 sub find_or_create {
2444   my $self     = shift;
2445   my $attrs    = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
2446   my $hash     = ref $_[0] eq 'HASH' ? shift : {@_};
2447   if (keys %$hash and my $row = $self->find($hash, $attrs) ) {
2448     return $row;
2449   }
2450   return $self->create($hash);
2451 }
2452
2453 =head2 update_or_create
2454
2455 =over 4
2456
2457 =item Arguments: \%col_values, { key => $unique_constraint }?
2458
2459 =item Return Value: $row_object
2460
2461 =back
2462
2463   $resultset->update_or_create({ col => $val, ... });
2464
2465 Like L</find_or_create>, but if a row is found it is immediately updated via
2466 C<< $found_row->update (\%col_values) >>.
2467
2468
2469 Takes an optional C<key> attribute to search on a specific unique constraint.
2470 For example:
2471
2472   # In your application
2473   my $cd = $schema->resultset('CD')->update_or_create(
2474     {
2475       artist => 'Massive Attack',
2476       title  => 'Mezzanine',
2477       year   => 1998,
2478     },
2479     { key => 'cd_artist_title' }
2480   );
2481
2482   $cd->cd_to_producer->update_or_create({
2483     producer => $producer,
2484     name => 'harry',
2485   }, {
2486     key => 'primary',
2487   });
2488
2489 B<Note>: Make sure to read the documentation of L</find> and understand the
2490 significance of the C<key> attribute, as its lack may skew your search, and
2491 subsequently result in spurious row creation.
2492
2493 B<Note>: Take care when using C<update_or_create> with a table having
2494 columns with default values that you intend to be automatically
2495 supplied by the database (e.g. an auto_increment primary key column).
2496 In normal usage, the value of such columns should NOT be included at
2497 all in the call to C<update_or_create>, even when set to C<undef>.
2498
2499 See also L</find> and L</find_or_create>. For information on how to declare
2500 unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
2501
2502 =cut
2503
2504 sub update_or_create {
2505   my $self = shift;
2506   my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
2507   my $cond = ref $_[0] eq 'HASH' ? shift : {@_};
2508
2509   my $row = $self->find($cond, $attrs);
2510   if (defined $row) {
2511     $row->update($cond);
2512     return $row;
2513   }
2514
2515   return $self->create($cond);
2516 }
2517
2518 =head2 update_or_new
2519
2520 =over 4
2521
2522 =item Arguments: \%col_values, { key => $unique_constraint }?
2523
2524 =item Return Value: $rowobject
2525
2526 =back
2527
2528   $resultset->update_or_new({ col => $val, ... });
2529
2530 Like L</find_or_new> but if a row is found it is immediately updated via
2531 C<< $found_row->update (\%col_values) >>.
2532
2533 For example:
2534
2535   # In your application
2536   my $cd = $schema->resultset('CD')->update_or_new(
2537     {
2538       artist => 'Massive Attack',
2539       title  => 'Mezzanine',
2540       year   => 1998,
2541     },
2542     { key => 'cd_artist_title' }
2543   );
2544
2545   if ($cd->in_storage) {
2546       # the cd was updated
2547   }
2548   else {
2549       # the cd is not yet in the database, let's insert it
2550       $cd->insert;
2551   }
2552
2553 B<Note>: Make sure to read the documentation of L</find> and understand the
2554 significance of the C<key> attribute, as its lack may skew your search, and
2555 subsequently result in spurious new objects.
2556
2557 B<Note>: Take care when using C<update_or_new> with a table having
2558 columns with default values that you intend to be automatically
2559 supplied by the database (e.g. an auto_increment primary key column).
2560 In normal usage, the value of such columns should NOT be included at
2561 all in the call to C<update_or_new>, even when set to C<undef>.
2562
2563 See also L</find>, L</find_or_create> and L</find_or_new>. 
2564
2565 =cut
2566
2567 sub update_or_new {
2568     my $self  = shift;
2569     my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} );
2570     my $cond  = ref $_[0] eq 'HASH' ? shift : {@_};
2571
2572     my $row = $self->find( $cond, $attrs );
2573     if ( defined $row ) {
2574         $row->update($cond);
2575         return $row;
2576     }
2577
2578     return $self->new_result($cond);
2579 }
2580
2581 =head2 get_cache
2582
2583 =over 4
2584
2585 =item Arguments: none
2586
2587 =item Return Value: \@cache_objects | undef
2588
2589 =back
2590
2591 Gets the contents of the cache for the resultset, if the cache is set.
2592
2593 The cache is populated either by using the L</prefetch> attribute to
2594 L</search> or by calling L</set_cache>.
2595
2596 =cut
2597
2598 sub get_cache {
2599   shift->{all_cache};
2600 }
2601
2602 =head2 set_cache
2603
2604 =over 4
2605
2606 =item Arguments: \@cache_objects
2607
2608 =item Return Value: \@cache_objects
2609
2610 =back
2611
2612 Sets the contents of the cache for the resultset. Expects an arrayref
2613 of objects of the same class as those produced by the resultset. Note that
2614 if the cache is set the resultset will return the cached objects rather
2615 than re-querying the database even if the cache attr is not set.
2616
2617 The contents of the cache can also be populated by using the
2618 L</prefetch> attribute to L</search>.
2619
2620 =cut
2621
2622 sub set_cache {
2623   my ( $self, $data ) = @_;
2624   $self->throw_exception("set_cache requires an arrayref")
2625       if defined($data) && (ref $data ne 'ARRAY');
2626   $self->{all_cache} = $data;
2627 }
2628
2629 =head2 clear_cache
2630
2631 =over 4
2632
2633 =item Arguments: none
2634
2635 =item Return Value: undef
2636
2637 =back
2638
2639 Clears the cache for the resultset.
2640
2641 =cut
2642
2643 sub clear_cache {
2644   shift->set_cache(undef);
2645 }
2646
2647 =head2 is_paged
2648
2649 =over 4
2650
2651 =item Arguments: none
2652
2653 =item Return Value: true, if the resultset has been paginated
2654
2655 =back
2656
2657 =cut
2658
2659 sub is_paged {
2660   my ($self) = @_;
2661   return !!$self->{attrs}{page};
2662 }
2663
2664 =head2 is_ordered
2665
2666 =over 4
2667
2668 =item Arguments: none
2669
2670 =item Return Value: true, if the resultset has been ordered with C<order_by>.
2671
2672 =back
2673
2674 =cut
2675
2676 sub is_ordered {
2677   my ($self) = @_;
2678   return scalar $self->result_source->storage->_extract_order_columns($self->{attrs}{order_by});
2679 }
2680
2681 =head2 related_resultset
2682
2683 =over 4
2684
2685 =item Arguments: $relationship_name
2686
2687 =item Return Value: $resultset
2688
2689 =back
2690
2691 Returns a related resultset for the supplied relationship name.
2692
2693   $artist_rs = $schema->resultset('CD')->related_resultset('Artist');
2694
2695 =cut
2696
2697 sub related_resultset {
2698   my ($self, $rel) = @_;
2699
2700   $self->{related_resultsets} ||= {};
2701   return $self->{related_resultsets}{$rel} ||= do {
2702     my $rsrc = $self->result_source;
2703     my $rel_info = $rsrc->relationship_info($rel);
2704
2705     $self->throw_exception(
2706       "search_related: result source '" . $rsrc->source_name .
2707         "' has no such relationship $rel")
2708       unless $rel_info;
2709
2710     my $attrs = $self->_chain_relationship($rel);
2711
2712     my $join_count = $attrs->{seen_join}{$rel};
2713
2714     my $alias = $self->result_source->storage
2715         ->relname_to_table_alias($rel, $join_count);
2716
2717     # since this is search_related, and we already slid the select window inwards
2718     # (the select/as attrs were deleted in the beginning), we need to flip all
2719     # left joins to inner, so we get the expected results
2720     # read the comment on top of the actual function to see what this does
2721     $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias);
2722
2723
2724     #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi
2725     delete @{$attrs}{qw(result_class alias)};
2726
2727     my $new_cache;
2728
2729     if (my $cache = $self->get_cache) {
2730       if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) {
2731         $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} }
2732                         @$cache ];
2733       }
2734     }
2735
2736     my $rel_source = $rsrc->related_source($rel);
2737
2738     my $new = do {
2739
2740       # The reason we do this now instead of passing the alias to the
2741       # search_rs below is that if you wrap/overload resultset on the
2742       # source you need to know what alias it's -going- to have for things
2743       # to work sanely (e.g. RestrictWithObject wants to be able to add
2744       # extra query restrictions, and these may need to be $alias.)
2745
2746       my $rel_attrs = $rel_source->resultset_attributes;
2747       local $rel_attrs->{alias} = $alias;
2748
2749       $rel_source->resultset
2750                  ->search_rs(
2751                      undef, {
2752                        %$attrs,
2753                        where => $attrs->{where},
2754                    });
2755     };
2756     $new->set_cache($new_cache) if $new_cache;
2757     $new;
2758   };
2759 }
2760
2761 =head2 current_source_alias
2762
2763 =over 4
2764
2765 =item Arguments: none
2766
2767 =item Return Value: $source_alias
2768
2769 =back
2770
2771 Returns the current table alias for the result source this resultset is built
2772 on, that will be used in the SQL query. Usually it is C<me>.
2773
2774 Currently the source alias that refers to the result set returned by a
2775 L</search>/L</find> family method depends on how you got to the resultset: it's
2776 C<me> by default, but eg. L</search_related> aliases it to the related result
2777 source name (and keeps C<me> referring to the original result set). The long
2778 term goal is to make L<DBIx::Class> always alias the current resultset as C<me>
2779 (and make this method unnecessary).
2780
2781 Thus it's currently necessary to use this method in predefined queries (see
2782 L<DBIx::Class::Manual::Cookbook/Predefined searches>) when referring to the
2783 source alias of the current result set:
2784
2785   # in a result set class
2786   sub modified_by {
2787     my ($self, $user) = @_;
2788
2789     my $me = $self->current_source_alias;
2790
2791     return $self->search(
2792       "$me.modified" => $user->id,
2793     );
2794   }
2795
2796 =cut
2797
2798 sub current_source_alias {
2799   my ($self) = @_;
2800
2801   return ($self->{attrs} || {})->{alias} || 'me';
2802 }
2803
2804 =head2 as_subselect_rs
2805
2806 =over 4
2807
2808 =item Arguments: none
2809
2810 =item Return Value: $resultset
2811
2812 =back
2813
2814 Act as a barrier to SQL symbols.  The resultset provided will be made into a
2815 "virtual view" by including it as a subquery within the from clause.  From this
2816 point on, any joined tables are inaccessible to ->search on the resultset (as if
2817 it were simply where-filtered without joins).  For example:
2818
2819  my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' });
2820
2821  # 'x' now pollutes the query namespace
2822
2823  # So the following works as expected
2824  my $ok_rs = $rs->search({'x.other' => 1});
2825
2826  # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and
2827  # def) we look for one row with contradictory terms and join in another table
2828  # (aliased 'x_2') which we never use
2829  my $broken_rs = $rs->search({'x.name' => 'def'});
2830
2831  my $rs2 = $rs->as_subselect_rs;
2832
2833  # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away
2834  my $not_joined_rs = $rs2->search({'x.other' => 1});
2835
2836  # works as expected: finds a 'table' row related to two x rows (abc and def)
2837  my $correctly_joined_rs = $rs2->search({'x.name' => 'def'});
2838
2839 Another example of when one might use this would be to select a subset of
2840 columns in a group by clause:
2841
2842  my $rs = $schema->resultset('Bar')->search(undef, {
2843    group_by => [qw{ id foo_id baz_id }],
2844  })->as_subselect_rs->search(undef, {
2845    columns => [qw{ id foo_id }]
2846  });
2847
2848 In the above example normally columns would have to be equal to the group by,
2849 but because we isolated the group by into a subselect the above works.
2850
2851 =cut
2852
2853 sub as_subselect_rs {
2854   my $self = shift;
2855
2856   my $attrs = $self->_resolved_attrs;
2857
2858   my $fresh_rs = (ref $self)->new (
2859     $self->result_source
2860   );
2861
2862   # these pieces will be locked in the subquery
2863   delete $fresh_rs->{cond};
2864   delete @{$fresh_rs->{attrs}}{qw/where bind/};
2865
2866   return $fresh_rs->search( {}, {
2867     from => [{
2868       $attrs->{alias} => $self->as_query,
2869       -alias         => $attrs->{alias},
2870       -source_handle => $self->result_source->handle,
2871     }],
2872     alias => $attrs->{alias},
2873   });
2874 }
2875
2876 # This code is called by search_related, and makes sure there
2877 # is clear separation between the joins before, during, and
2878 # after the relationship. This information is needed later
2879 # in order to properly resolve prefetch aliases (any alias
2880 # with a relation_chain_depth less than the depth of the
2881 # current prefetch is not considered)
2882 #
2883 # The increments happen twice per join. An even number means a
2884 # relationship specified via a search_related, whereas an odd
2885 # number indicates a join/prefetch added via attributes
2886 #
2887 # Also this code will wrap the current resultset (the one we
2888 # chain to) in a subselect IFF it contains limiting attributes
2889 sub _chain_relationship {
2890   my ($self, $rel) = @_;
2891   my $source = $self->result_source;
2892   my $attrs = { %{$self->{attrs}||{}} };
2893
2894   # we need to take the prefetch the attrs into account before we
2895   # ->_resolve_join as otherwise they get lost - captainL
2896   my $join = $self->_merge_attr( $attrs->{join}, $attrs->{prefetch} );
2897
2898   delete @{$attrs}{qw/join prefetch collapse group_by distinct select as columns +select +as +columns/};
2899
2900   my $seen = { %{ (delete $attrs->{seen_join}) || {} } };
2901
2902   my $from;
2903   my @force_subq_attrs = qw/offset rows group_by having/;
2904
2905   if (
2906     ($attrs->{from} && ref $attrs->{from} ne 'ARRAY')
2907       ||
2908     $self->_has_resolved_attr (@force_subq_attrs)
2909   ) {
2910     # Nuke the prefetch (if any) before the new $rs attrs
2911     # are resolved (prefetch is useless - we are wrapping
2912     # a subquery anyway).
2913     my $rs_copy = $self->search;
2914     $rs_copy->{attrs}{join} = $self->_merge_attr (
2915       $rs_copy->{attrs}{join},
2916       delete $rs_copy->{attrs}{prefetch},
2917     );
2918
2919     $from = [{
2920       -source_handle => $source->handle,
2921       -alias => $attrs->{alias},
2922       $attrs->{alias} => $rs_copy->as_query,
2923     }];
2924     delete @{$attrs}{@force_subq_attrs, qw/where bind/};
2925     $seen->{-relation_chain_depth} = 0;
2926   }
2927   elsif ($attrs->{from}) {  #shallow copy suffices
2928     $from = [ @{$attrs->{from}} ];
2929   }
2930   else {
2931     $from = [{
2932       -source_handle => $source->handle,
2933       -alias => $attrs->{alias},
2934       $attrs->{alias} => $source->from,
2935     }];
2936   }
2937
2938   my $jpath = ($seen->{-relation_chain_depth})
2939     ? $from->[-1][0]{-join_path}
2940     : [];
2941
2942   my @requested_joins = $source->_resolve_join(
2943     $join,
2944     $attrs->{alias},
2945     $seen,
2946     $jpath,
2947   );
2948
2949   push @$from, @requested_joins;
2950
2951   $seen->{-relation_chain_depth}++;
2952
2953   # if $self already had a join/prefetch specified on it, the requested
2954   # $rel might very well be already included. What we do in this case
2955   # is effectively a no-op (except that we bump up the chain_depth on
2956   # the join in question so we could tell it *is* the search_related)
2957   my $already_joined;
2958
2959   # we consider the last one thus reverse
2960   for my $j (reverse @requested_joins) {
2961     my ($last_j) = keys %{$j->[0]{-join_path}[-1]};
2962     if ($rel eq $last_j) {
2963       $j->[0]{-relation_chain_depth}++;
2964       $already_joined++;
2965       last;
2966     }
2967   }
2968
2969   unless ($already_joined) {
2970     push @$from, $source->_resolve_join(
2971       $rel,
2972       $attrs->{alias},
2973       $seen,
2974       $jpath,
2975     );
2976   }
2977
2978   $seen->{-relation_chain_depth}++;
2979
2980   return {%$attrs, from => $from, seen_join => $seen};
2981 }
2982
2983 # too many times we have to do $attrs = { %{$self->_resolved_attrs} }
2984 sub _resolved_attrs_copy {
2985   my $self = shift;
2986   return { %{$self->_resolved_attrs (@_)} };
2987 }
2988
2989 sub _resolved_attrs {
2990   my $self = shift;
2991   return $self->{_attrs} if $self->{_attrs};
2992
2993   my $attrs  = { %{ $self->{attrs} || {} } };
2994   my $source = $self->result_source;
2995   my $alias  = $attrs->{alias};
2996
2997   $attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols};
2998   my @colbits;
2999
3000   # build columns (as long as select isn't set) into a set of as/select hashes
3001   unless ( $attrs->{select} ) {
3002
3003     my @cols;
3004     if ( ref $attrs->{columns} eq 'ARRAY' ) {
3005       @cols = @{ delete $attrs->{columns}}
3006     } elsif ( defined $attrs->{columns} ) {
3007       @cols = delete $attrs->{columns}
3008     } else {
3009       @cols = $source->columns
3010     }
3011
3012     for (@cols) {
3013       if ( ref $_ eq 'HASH' ) {
3014         push @colbits, $_
3015       } else {
3016         my $key = /^\Q${alias}.\E(.+)$/
3017           ? "$1"
3018           : "$_";
3019         my $value = /\./
3020           ? "$_"
3021           : "${alias}.$_";
3022         push @colbits, { $key => $value };
3023       }
3024     }
3025   }
3026
3027   # add the additional columns on
3028   foreach (qw{include_columns +columns}) {
3029     if ( $attrs->{$_} ) {
3030       my @list = ( ref($attrs->{$_}) eq 'ARRAY' )
3031         ? @{ delete $attrs->{$_} }
3032         : delete $attrs->{$_};
3033       for (@list) {
3034         if ( ref($_) eq 'HASH' ) {
3035           push @colbits, $_
3036         } else {
3037           my $key = ( split /\./, $_ )[-1];
3038           my $value = ( /\./ ? $_ : "$alias.$_" );
3039           push @colbits, { $key => $value };
3040         }
3041       }
3042     }
3043   }
3044
3045   # start with initial select items
3046   if ( $attrs->{select} ) {
3047     $attrs->{select} =
3048         ( ref $attrs->{select} eq 'ARRAY' )
3049       ? [ @{ $attrs->{select} } ]
3050       : [ $attrs->{select} ];
3051
3052     if ( $attrs->{as} ) {
3053       $attrs->{as} =
3054         (
3055           ref $attrs->{as} eq 'ARRAY'
3056             ? [ @{ $attrs->{as} } ]
3057             : [ $attrs->{as} ]
3058         )
3059     } else {
3060       $attrs->{as} = [ map {
3061          m/^\Q${alias}.\E(.+)$/
3062            ? $1
3063            : $_
3064          } @{ $attrs->{select} }
3065       ]
3066     }
3067   }
3068   else {
3069
3070     # otherwise we intialise select & as to empty
3071     $attrs->{select} = [];
3072     $attrs->{as}     = [];
3073   }
3074
3075   # now add colbits to select/as
3076   push @{ $attrs->{select} }, map values %{$_}, @colbits;
3077   push @{ $attrs->{as}     }, map keys   %{$_}, @colbits;
3078
3079   if ( my $adds = delete $attrs->{'+select'} ) {
3080     $adds = [$adds] unless ref $adds eq 'ARRAY';
3081     push @{ $attrs->{select} },
3082       map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds;
3083   }
3084   if ( my $adds = delete $attrs->{'+as'} ) {
3085     $adds = [$adds] unless ref $adds eq 'ARRAY';
3086     push @{ $attrs->{as} }, @$adds;
3087   }
3088
3089   $attrs->{from} ||= [{
3090     -source_handle => $source->handle,
3091     -alias => $self->{attrs}{alias},
3092     $self->{attrs}{alias} => $source->from,
3093   }];
3094
3095   if ( $attrs->{join} || $attrs->{prefetch} ) {
3096
3097     $self->throw_exception ('join/prefetch can not be used with a custom {from}')
3098       if ref $attrs->{from} ne 'ARRAY';
3099
3100     my $join = delete $attrs->{join} || {};
3101
3102     if ( defined $attrs->{prefetch} ) {
3103       $join = $self->_merge_attr( $join, $attrs->{prefetch} );
3104     }
3105
3106     $attrs->{from} =    # have to copy here to avoid corrupting the original
3107       [
3108         @{ $attrs->{from} },
3109         $source->_resolve_join(
3110           $join,
3111           $alias,
3112           { %{ $attrs->{seen_join} || {} } },
3113           ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
3114             ? $attrs->{from}[-1][0]{-join_path}
3115             : []
3116           ,
3117         )
3118       ];
3119   }
3120
3121   if ( defined $attrs->{order_by} ) {
3122     $attrs->{order_by} = (
3123       ref( $attrs->{order_by} ) eq 'ARRAY'
3124       ? [ @{ $attrs->{order_by} } ]
3125       : [ $attrs->{order_by} || () ]
3126     );
3127   }
3128
3129   if ($attrs->{group_by} and ref $attrs->{group_by} ne 'ARRAY') {
3130     $attrs->{group_by} = [ $attrs->{group_by} ];
3131   }
3132
3133   # generate the distinct induced group_by early, as prefetch will be carried via a
3134   # subquery (since a group_by is present)
3135   if (delete $attrs->{distinct}) {
3136     if ($attrs->{group_by}) {
3137       carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
3138     }
3139     else {
3140       $attrs->{group_by} = $source->storage->_group_over_selection (
3141         @{$attrs}{qw/from select order_by/}
3142       );
3143     }
3144   }
3145
3146   $attrs->{collapse} ||= {};
3147   if ( my $prefetch = delete $attrs->{prefetch} ) {
3148     $prefetch = $self->_merge_attr( {}, $prefetch );
3149
3150     my $prefetch_ordering = [];
3151
3152     # this is a separate structure (we don't look in {from} directly)
3153     # as the resolver needs to shift things off the lists to work
3154     # properly (identical-prefetches on different branches)
3155     my $join_map = {};
3156     if (ref $attrs->{from} eq 'ARRAY') {
3157
3158       my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0;
3159
3160       for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) {
3161         next unless $j->[0]{-alias};
3162         next unless $j->[0]{-join_path};
3163         next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth;
3164
3165         my @jpath = map { keys %$_ } @{$j->[0]{-join_path}};
3166
3167         my $p = $join_map;
3168         $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries
3169         push @{$p->{-join_aliases} }, $j->[0]{-alias};
3170       }
3171     }
3172
3173     my @prefetch =
3174       $source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} );
3175
3176     # we need to somehow mark which columns came from prefetch
3177     $attrs->{_prefetch_select} = [ map { $_->[0] } @prefetch ];
3178
3179     push @{ $attrs->{select} }, @{$attrs->{_prefetch_select}};
3180     push @{ $attrs->{as} }, (map { $_->[1] } @prefetch);
3181
3182     push( @{$attrs->{order_by}}, @$prefetch_ordering );
3183     $attrs->{_collapse_order_by} = \@$prefetch_ordering;
3184   }
3185
3186   # if both page and offset are specified, produce a combined offset
3187   # even though it doesn't make much sense, this is what pre 081xx has
3188   # been doing
3189   if (my $page = delete $attrs->{page}) {
3190     $attrs->{offset} =
3191       ($attrs->{rows} * ($page - 1))
3192             +
3193       ($attrs->{offset} || 0)
3194     ;
3195   }
3196
3197   return $self->{_attrs} = $attrs;
3198 }
3199
3200 sub _rollout_attr {
3201   my ($self, $attr) = @_;
3202
3203   if (ref $attr eq 'HASH') {
3204     return $self->_rollout_hash($attr);
3205   } elsif (ref $attr eq 'ARRAY') {
3206     return $self->_rollout_array($attr);
3207   } else {
3208     return [$attr];
3209   }
3210 }
3211
3212 sub _rollout_array {
3213   my ($self, $attr) = @_;
3214
3215   my @rolled_array;
3216   foreach my $element (@{$attr}) {
3217     if (ref $element eq 'HASH') {
3218       push( @rolled_array, @{ $self->_rollout_hash( $element ) } );
3219     } elsif (ref $element eq 'ARRAY') {
3220       #  XXX - should probably recurse here
3221       push( @rolled_array, @{$self->_rollout_array($element)} );
3222     } else {
3223       push( @rolled_array, $element );
3224     }
3225   }
3226   return \@rolled_array;
3227 }
3228
3229 sub _rollout_hash {
3230   my ($self, $attr) = @_;
3231
3232   my @rolled_array;
3233   foreach my $key (keys %{$attr}) {
3234     push( @rolled_array, { $key => $attr->{$key} } );
3235   }
3236   return \@rolled_array;
3237 }
3238
3239 sub _calculate_score {
3240   my ($self, $a, $b) = @_;
3241
3242   if (defined $a xor defined $b) {
3243     return 0;
3244   }
3245   elsif (not defined $a) {
3246     return 1;
3247   }
3248
3249   if (ref $b eq 'HASH') {
3250     my ($b_key) = keys %{$b};
3251     if (ref $a eq 'HASH') {
3252       my ($a_key) = keys %{$a};
3253       if ($a_key eq $b_key) {
3254         return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} ));
3255       } else {
3256         return 0;
3257       }
3258     } else {
3259       return ($a eq $b_key) ? 1 : 0;
3260     }
3261   } else {
3262     if (ref $a eq 'HASH') {
3263       my ($a_key) = keys %{$a};
3264       return ($b eq $a_key) ? 1 : 0;
3265     } else {
3266       return ($b eq $a) ? 1 : 0;
3267     }
3268   }
3269 }
3270
3271 sub _merge_attr {
3272   my ($self, $orig, $import) = @_;
3273
3274   return $import unless defined($orig);
3275   return $orig unless defined($import);
3276
3277   $orig = $self->_rollout_attr($orig);
3278   $import = $self->_rollout_attr($import);
3279
3280   my $seen_keys;
3281   foreach my $import_element ( @{$import} ) {
3282     # find best candidate from $orig to merge $b_element into
3283     my $best_candidate = { position => undef, score => 0 }; my $position = 0;
3284     foreach my $orig_element ( @{$orig} ) {
3285       my $score = $self->_calculate_score( $orig_element, $import_element );
3286       if ($score > $best_candidate->{score}) {
3287         $best_candidate->{position} = $position;
3288         $best_candidate->{score} = $score;
3289       }
3290       $position++;
3291     }
3292     my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
3293
3294     if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
3295       push( @{$orig}, $import_element );
3296     } else {
3297       my $orig_best = $orig->[$best_candidate->{position}];
3298       # merge orig_best and b_element together and replace original with merged
3299       if (ref $orig_best ne 'HASH') {
3300         $orig->[$best_candidate->{position}] = $import_element;
3301       } elsif (ref $import_element eq 'HASH') {
3302         my ($key) = keys %{$orig_best};
3303         $orig->[$best_candidate->{position}] = { $key => $self->_merge_attr($orig_best->{$key}, $import_element->{$key}) };
3304       }
3305     }
3306     $seen_keys->{$import_key} = 1; # don't merge the same key twice
3307   }
3308
3309   return $orig;
3310 }
3311
3312 sub result_source {
3313     my $self = shift;
3314
3315     if (@_) {
3316         $self->_source_handle($_[0]->handle);
3317     } else {
3318         $self->_source_handle->resolve;
3319     }
3320 }
3321
3322 =head2 throw_exception
3323
3324 See L<DBIx::Class::Schema/throw_exception> for details.
3325
3326 =cut
3327
3328 sub throw_exception {
3329   my $self=shift;
3330
3331   if (ref $self && $self->_source_handle->schema) {
3332     $self->_source_handle->schema->throw_exception(@_)
3333   }
3334   else {
3335     DBIx::Class::Exception->throw(@_);
3336   }
3337 }
3338
3339 # XXX: FIXME: Attributes docs need clearing up
3340
3341 =head1 ATTRIBUTES
3342
3343 Attributes are used to refine a ResultSet in various ways when
3344 searching for data. They can be passed to any method which takes an
3345 C<\%attrs> argument. See L</search>, L</search_rs>, L</find>,
3346 L</count>.
3347
3348 These are in no particular order:
3349
3350 =head2 order_by
3351
3352 =over 4
3353
3354 =item Value: ( $order_by | \@order_by | \%order_by )
3355
3356 =back
3357
3358 Which column(s) to order the results by.
3359
3360 [The full list of suitable values is documented in
3361 L<SQL::Abstract/"ORDER BY CLAUSES">; the following is a summary of
3362 common options.]
3363
3364 If a single column name, or an arrayref of names is supplied, the
3365 argument is passed through directly to SQL. The hashref syntax allows
3366 for connection-agnostic specification of ordering direction:
3367
3368  For descending order:
3369
3370   order_by => { -desc => [qw/col1 col2 col3/] }
3371
3372  For explicit ascending order:
3373
3374   order_by => { -asc => 'col' }
3375
3376 The old scalarref syntax (i.e. order_by => \'year DESC') is still
3377 supported, although you are strongly encouraged to use the hashref
3378 syntax as outlined above.
3379
3380 =head2 columns
3381
3382 =over 4
3383
3384 =item Value: \@columns
3385
3386 =back
3387
3388 Shortcut to request a particular set of columns to be retrieved. Each
3389 column spec may be a string (a table column name), or a hash (in which
3390 case the key is the C<as> value, and the value is used as the C<select>
3391 expression). Adds C<me.> onto the start of any column without a C<.> in
3392 it and sets C<select> from that, then auto-populates C<as> from
3393 C<select> as normal. (You may also use the C<cols> attribute, as in
3394 earlier versions of DBIC.)
3395
3396 Essentially C<columns> does the same as L</select> and L</as>.
3397
3398     columns => [ 'foo', { bar => 'baz' } ]
3399
3400 is the same as
3401
3402     select => [qw/foo baz/],
3403     as => [qw/foo bar/]
3404
3405 =head2 +columns
3406
3407 =over 4
3408
3409 =item Value: \@columns
3410
3411 =back
3412
3413 Indicates additional columns to be selected from storage. Works the same
3414 as L</columns> but adds columns to the selection. (You may also use the
3415 C<include_columns> attribute, as in earlier versions of DBIC). For
3416 example:-
3417
3418   $schema->resultset('CD')->search(undef, {
3419     '+columns' => ['artist.name'],
3420     join => ['artist']
3421   });
3422
3423 would return all CDs and include a 'name' column to the information
3424 passed to object inflation. Note that the 'artist' is the name of the
3425 column (or relationship) accessor, and 'name' is the name of the column
3426 accessor in the related table.
3427
3428 =head2 include_columns
3429
3430 =over 4
3431
3432 =item Value: \@columns
3433
3434 =back
3435
3436 Deprecated.  Acts as a synonym for L</+columns> for backward compatibility.
3437
3438 =head2 select
3439
3440 =over 4
3441
3442 =item Value: \@select_columns
3443
3444 =back
3445
3446 Indicates which columns should be selected from the storage. You can use
3447 column names, or in the case of RDBMS back ends, function or stored procedure
3448 names:
3449
3450   $rs = $schema->resultset('Employee')->search(undef, {
3451     select => [
3452       'name',
3453       { count => 'employeeid' },
3454       { max => { length => 'name' }, -as => 'longest_name' }
3455     ]
3456   });
3457
3458   # Equivalent SQL
3459   SELECT name, COUNT( employeeid ), MAX( LENGTH( name ) ) AS longest_name FROM employee
3460
3461 B<NOTE:> You will almost always need a corresponding L</as> attribute when you
3462 use L</select>, to instruct DBIx::Class how to store the result of the column.
3463 Also note that the L</as> attribute has nothing to do with the SQL-side 'AS'
3464 identifier aliasing. You can however alias a function, so you can use it in
3465 e.g. an C<ORDER BY> clause. This is done via the C<-as> B<select function
3466 attribute> supplied as shown in the example above.
3467
3468 =head2 +select
3469
3470 =over 4
3471
3472 Indicates additional columns to be selected from storage.  Works the same as
3473 L</select> but adds columns to the default selection, instead of specifying
3474 an explicit list.
3475
3476 =back
3477
3478 =head2 +as
3479
3480 =over 4
3481
3482 Indicates additional column names for those added via L</+select>. See L</as>.
3483
3484 =back
3485
3486 =head2 as
3487
3488 =over 4
3489
3490 =item Value: \@inflation_names
3491
3492 =back
3493
3494 Indicates column names for object inflation. That is L</as> indicates the
3495 slot name in which the column value will be stored within the
3496 L<Row|DBIx::Class::Row> object. The value will then be accessible via this
3497 identifier by the C<get_column> method (or via the object accessor B<if one
3498 with the same name already exists>) as shown below. The L</as> attribute has
3499 B<nothing to do> with the SQL-side C<AS>. See L</select> for details.
3500
3501   $rs = $schema->resultset('Employee')->search(undef, {
3502     select => [
3503       'name',
3504       { count => 'employeeid' },
3505       { max => { length => 'name' }, -as => 'longest_name' }
3506     ],
3507     as => [qw/
3508       name
3509       employee_count
3510       max_name_length
3511     /],
3512   });
3513
3514 If the object against which the search is performed already has an accessor
3515 matching a column name specified in C<as>, the value can be retrieved using
3516 the accessor as normal:
3517
3518   my $name = $employee->name();
3519
3520 If on the other hand an accessor does not exist in the object, you need to
3521 use C<get_column> instead:
3522
3523   my $employee_count = $employee->get_column('employee_count');
3524
3525 You can create your own accessors if required - see
3526 L<DBIx::Class::Manual::Cookbook> for details.
3527
3528 =head2 join
3529
3530 =over 4
3531
3532 =item Value: ($rel_name | \@rel_names | \%rel_names)
3533
3534 =back
3535
3536 Contains a list of relationships that should be joined for this query.  For
3537 example:
3538
3539   # Get CDs by Nine Inch Nails
3540   my $rs = $schema->resultset('CD')->search(
3541     { 'artist.name' => 'Nine Inch Nails' },
3542     { join => 'artist' }
3543   );
3544
3545 Can also contain a hash reference to refer to the other relation's relations.
3546 For example:
3547
3548   package MyApp::Schema::Track;
3549   use base qw/DBIx::Class/;
3550   __PACKAGE__->table('track');
3551   __PACKAGE__->add_columns(qw/trackid cd position title/);
3552   __PACKAGE__->set_primary_key('trackid');
3553   __PACKAGE__->belongs_to(cd => 'MyApp::Schema::CD');
3554   1;
3555
3556   # In your application
3557   my $rs = $schema->resultset('Artist')->search(
3558     { 'track.title' => 'Teardrop' },
3559     {
3560       join     => { cd => 'track' },
3561       order_by => 'artist.name',
3562     }
3563   );
3564
3565 You need to use the relationship (not the table) name in  conditions,
3566 because they are aliased as such. The current table is aliased as "me", so
3567 you need to use me.column_name in order to avoid ambiguity. For example:
3568
3569   # Get CDs from 1984 with a 'Foo' track
3570   my $rs = $schema->resultset('CD')->search(
3571     {
3572       'me.year' => 1984,
3573       'tracks.name' => 'Foo'
3574     },
3575     { join => 'tracks' }
3576   );
3577
3578 If the same join is supplied twice, it will be aliased to <rel>_2 (and
3579 similarly for a third time). For e.g.
3580
3581   my $rs = $schema->resultset('Artist')->search({
3582     'cds.title'   => 'Down to Earth',
3583     'cds_2.title' => 'Popular',
3584   }, {
3585     join => [ qw/cds cds/ ],
3586   });
3587
3588 will return a set of all artists that have both a cd with title 'Down
3589 to Earth' and a cd with title 'Popular'.
3590
3591 If you want to fetch related objects from other tables as well, see C<prefetch>
3592 below.
3593
3594 For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
3595
3596 =head2 prefetch
3597
3598 =over 4
3599
3600 =item Value: ($rel_name | \@rel_names | \%rel_names)
3601
3602 =back
3603
3604 Contains one or more relationships that should be fetched along with
3605 the main query (when they are accessed afterwards the data will
3606 already be available, without extra queries to the database).  This is
3607 useful for when you know you will need the related objects, because it
3608 saves at least one query:
3609
3610   my $rs = $schema->resultset('Tag')->search(
3611     undef,
3612     {
3613       prefetch => {
3614         cd => 'artist'
3615       }
3616     }
3617   );
3618
3619 The initial search results in SQL like the following:
3620
3621   SELECT tag.*, cd.*, artist.* FROM tag
3622   JOIN cd ON tag.cd = cd.cdid
3623   JOIN artist ON cd.artist = artist.artistid
3624
3625 L<DBIx::Class> has no need to go back to the database when we access the
3626 C<cd> or C<artist> relationships, which saves us two SQL statements in this
3627 case.
3628
3629 Simple prefetches will be joined automatically, so there is no need
3630 for a C<join> attribute in the above search.
3631
3632 C<prefetch> can be used with the following relationship types: C<belongs_to>,
3633 C<has_one> (or if you're using C<add_relationship>, any relationship declared
3634 with an accessor type of 'single' or 'filter'). A more complex example that
3635 prefetches an artists cds, the tracks on those cds, and the tags associated
3636 with that artist is given below (assuming many-to-many from artists to tags):
3637
3638  my $rs = $schema->resultset('Artist')->search(
3639    undef,
3640    {
3641      prefetch => [
3642        { cds => 'tracks' },
3643        { artist_tags => 'tags' }
3644      ]
3645    }
3646  );
3647
3648
3649 B<NOTE:> If you specify a C<prefetch> attribute, the C<join> and C<select>
3650 attributes will be ignored.
3651
3652 B<CAVEATs>: Prefetch does a lot of deep magic. As such, it may not behave
3653 exactly as you might expect.
3654
3655 =over 4
3656
3657 =item *
3658
3659 Prefetch uses the L</cache> to populate the prefetched relationships. This
3660 may or may not be what you want.
3661
3662 =item *
3663
3664 If you specify a condition on a prefetched relationship, ONLY those
3665 rows that match the prefetched condition will be fetched into that relationship.
3666 This means that adding prefetch to a search() B<may alter> what is returned by
3667 traversing a relationship. So, if you have C<< Artist->has_many(CDs) >> and you do
3668
3669   my $artist_rs = $schema->resultset('Artist')->search({
3670       'cds.year' => 2008,
3671   }, {
3672       join => 'cds',
3673   });
3674
3675   my $count = $artist_rs->first->cds->count;
3676
3677   my $artist_rs_prefetch = $artist_rs->search( {}, { prefetch => 'cds' } );
3678
3679   my $prefetch_count = $artist_rs_prefetch->first->cds->count;
3680
3681   cmp_ok( $count, '==', $prefetch_count, "Counts should be the same" );
3682
3683 that cmp_ok() may or may not pass depending on the datasets involved. This
3684 behavior may or may not survive the 0.09 transition.
3685
3686 =back
3687
3688 =head2 page
3689
3690 =over 4
3691
3692 =item Value: $page
3693
3694 =back
3695
3696 Makes the resultset paged and specifies the page to retrieve. Effectively
3697 identical to creating a non-pages resultset and then calling ->page($page)
3698 on it.
3699
3700 If L<rows> attribute is not specified it defaults to 10 rows per page.
3701
3702 When you have a paged resultset, L</count> will only return the number
3703 of rows in the page. To get the total, use the L</pager> and call
3704 C<total_entries> on it.
3705
3706 =head2 rows
3707
3708 =over 4
3709
3710 =item Value: $rows
3711
3712 =back
3713
3714 Specifies the maximum number of rows for direct retrieval or the number of
3715 rows per page if the page attribute or method is used.
3716
3717 =head2 offset
3718
3719 =over 4
3720
3721 =item Value: $offset
3722
3723 =back
3724
3725 Specifies the (zero-based) row number for the  first row to be returned, or the
3726 of the first row of the first page if paging is used.
3727
3728 =head2 group_by
3729
3730 =over 4
3731
3732 =item Value: \@columns
3733
3734 =back
3735
3736 A arrayref of columns to group by. Can include columns of joined tables.
3737
3738   group_by => [qw/ column1 column2 ... /]
3739
3740 =head2 having
3741
3742 =over 4
3743
3744 =item Value: $condition
3745
3746 =back
3747
3748 HAVING is a select statement attribute that is applied between GROUP BY and
3749 ORDER BY. It is applied to the after the grouping calculations have been
3750 done.
3751
3752   having => { 'count(employee)' => { '>=', 100 } }
3753
3754 =head2 distinct
3755
3756 =over 4
3757
3758 =item Value: (0 | 1)
3759
3760 =back
3761
3762 Set to 1 to group by all columns. If the resultset already has a group_by
3763 attribute, this setting is ignored and an appropriate warning is issued.
3764
3765 =head2 where
3766
3767 =over 4
3768
3769 Adds to the WHERE clause.
3770
3771   # only return rows WHERE deleted IS NULL for all searches
3772   __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); )
3773
3774 Can be overridden by passing C<< { where => undef } >> as an attribute
3775 to a resultset.
3776
3777 =back
3778
3779 =head2 cache
3780
3781 Set to 1 to cache search results. This prevents extra SQL queries if you
3782 revisit rows in your ResultSet:
3783
3784   my $resultset = $schema->resultset('Artist')->search( undef, { cache => 1 } );
3785
3786   while( my $artist = $resultset->next ) {
3787     ... do stuff ...
3788   }
3789
3790   $rs->first; # without cache, this would issue a query
3791
3792 By default, searches are not cached.
3793
3794 For more examples of using these attributes, see
3795 L<DBIx::Class::Manual::Cookbook>.
3796
3797 =head2 for
3798
3799 =over 4
3800
3801 =item Value: ( 'update' | 'shared' )
3802
3803 =back
3804
3805 Set to 'update' for a SELECT ... FOR UPDATE or 'shared' for a SELECT
3806 ... FOR SHARED.
3807
3808 =cut
3809
3810 1;