Updated version and Changes for 0.06999_02
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm
CommitLineData
9c992ba1 1package DBIx::Class::ResultSource;
2
3use strict;
4use warnings;
5
6use DBIx::Class::ResultSet;
701da8c4 7use Carp::Clan qw/^DBIx::Class/;
6da5894c 8use Storable;
9
9c992ba1 10use base qw/DBIx::Class/;
11__PACKAGE__->load_components(qw/AccessorGroup/);
12
aa1088bf 13__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
14 _columns _primaries _unique_constraints name resultset_attributes
15 schema from _relationships/);
16
17__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
bab77431 18 result_class source_name/);
9c992ba1 19
75d07914 20=head1 NAME
9c992ba1 21
22DBIx::Class::ResultSource - Result source object
23
24=head1 SYNOPSIS
25
26=head1 DESCRIPTION
27
28A ResultSource is a component of a schema from which results can be directly
29retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
30
31=head1 METHODS
32
7eb4ecc8 33=pod
34
35=head2 new
36
37 $class->new();
38
39 $class->new({attribute_name => value});
40
41Creates a new ResultSource object. Not normally called directly by end users.
42
9c992ba1 43=cut
44
45sub new {
46 my ($class, $attrs) = @_;
47 $class = ref $class if ref $class;
1225fc4d 48 my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
9c992ba1 49 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
5ac6a044 50 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
6da5894c 51 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
52 $new->{_columns} = { %{$new->{_columns}||{}} };
53 $new->{_relationships} = { %{$new->{_relationships}||{}} };
9c992ba1 54 $new->{name} ||= "!!NAME NOT SET!!";
5afa2a15 55 $new->{_columns_info_loaded} ||= 0;
9c992ba1 56 return $new;
57}
58
988bf309 59=pod
60
5ac6a044 61=head2 add_columns
62
63 $table->add_columns(qw/col1 col2 col3/);
64
65 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
66
2053ab2a 67Adds columns to the result source. If supplied key => hashref pairs, uses
68the hashref as the column_info for that column. Repeated calls of this
69method will add more columns, not replace them.
5ac6a044 70
2053ab2a 71The contents of the column_info are not set in stone. The following
72keys are currently recognised/used by DBIx::Class:
988bf309 73
74=over 4
75
75d07914 76=item accessor
988bf309 77
78Use this to set the name of the accessor for this column. If unset,
79the name of the column will be used.
80
81=item data_type
82
2053ab2a 83This contains the column type. It is automatically filled by the
988bf309 84L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
2053ab2a 85L<DBIx::Class::Schema::Loader> module. If you do not enter a
988bf309 86data_type, DBIx::Class will attempt to retrieve it from the
2053ab2a 87database for you, using L<DBI>'s column_info method. The values of this
988bf309 88key are typically upper-cased.
89
2053ab2a 90Currently there is no standard set of values for the data_type. Use
91whatever your database supports.
988bf309 92
93=item size
94
95The length of your column, if it is a column type that can have a size
75d07914 96restriction. This is currently not used by DBIx::Class.
988bf309 97
98=item is_nullable
99
2053ab2a 100Set this to a true value for a columns that is allowed to contain
101NULL values. This is currently not used by DBIx::Class.
988bf309 102
103=item is_auto_increment
104
2053ab2a 105Set this to a true value for a column whose value is somehow
106automatically set. This is used to determine which columns to empty
e666492c 107when cloning objects using C<copy>.
988bf309 108
109=item is_foreign_key
110
2053ab2a 111Set this to a true value for a column that contains a key from a
988bf309 112foreign table. This is currently not used by DBIx::Class.
113
114=item default_value
115
2053ab2a 116Set this to the default value which will be inserted into a column
117by the database. Can contain either a value or a function. This is
75d07914 118currently not used by DBIx::Class.
988bf309 119
120=item sequence
121
2053ab2a 122Set this on a primary key column to the name of the sequence used to
123generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
124will attempt to retrieve the name of the sequence from the database
125automatically.
988bf309 126
127=back
128
5ac6a044 129=head2 add_column
130
131 $table->add_column('col' => \%info?);
132
2053ab2a 133Convenience alias to add_columns.
5ac6a044 134
135=cut
136
9c992ba1 137sub add_columns {
138 my ($self, @cols) = @_;
8e04bf91 139 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
002a359a 140
20518cb4 141 my @added;
142 my $columns = $self->_columns;
9c992ba1 143 while (my $col = shift @cols) {
8e04bf91 144 # If next entry is { ... } use that for the column info, if not
145 # use an empty hashref
30126ac7 146 my $column_info = ref $cols[0] ? shift(@cols) : {};
20518cb4 147 push(@added, $col) unless exists $columns->{$col};
20518cb4 148 $columns->{$col} = $column_info;
9c992ba1 149 }
20518cb4 150 push @{ $self->_ordered_columns }, @added;
30126ac7 151 return $self;
9c992ba1 152}
153
154*add_column = \&add_columns;
155
3842b955 156=head2 has_column
157
988bf309 158 if ($obj->has_column($col)) { ... }
159
2053ab2a 160Returns true if the source has a column of this name, false otherwise.
988bf309 161
162=cut
9c992ba1 163
164sub has_column {
165 my ($self, $column) = @_;
166 return exists $self->_columns->{$column};
167}
168
87c4e602 169=head2 column_info
9c992ba1 170
988bf309 171 my $info = $obj->column_info($col);
9c992ba1 172
988bf309 173Returns the column metadata hashref for a column. See the description
174of add_column for information on the contents of the hashref.
9c992ba1 175
988bf309 176=cut
9c992ba1 177
178sub column_info {
179 my ($self, $column) = @_;
75d07914 180 $self->throw_exception("No such column $column")
701da8c4 181 unless exists $self->_columns->{$column};
5afa2a15 182 #warn $self->{_columns_info_loaded}, "\n";
75d07914 183 if ( ! $self->_columns->{$column}{data_type}
184 and ! $self->{_columns_info_loaded}
8e04bf91 185 and $self->schema and $self->storage )
186 {
187 $self->{_columns_info_loaded}++;
188 my $info;
0b88a5bb 189 my $lc_info;
75d07914 190 # eval for the case of storage without table
0b88a5bb 191 eval { $info = $self->storage->columns_info_for( $self->from, keys %{$self->_columns} ) };
8e04bf91 192 unless ($@) {
0b88a5bb 193 for my $realcol ( keys %{$info} ) {
194 $lc_info->{lc $realcol} = $info->{$realcol};
195 }
8e04bf91 196 foreach my $col ( keys %{$self->_columns} ) {
416e92f7 197 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
a953d8d9 198 }
8e04bf91 199 }
a953d8d9 200 }
9c992ba1 201 return $self->_columns->{$column};
202}
203
204=head2 columns
205
20518cb4 206 my @column_names = $obj->columns;
207
2053ab2a 208Returns all column names in the order they were declared to add_columns.
87f0da6a 209
210=cut
9c992ba1 211
212sub columns {
8e04bf91 213 my $self = shift;
aa1088bf 214 $self->throw_exception(
215 "columns() is a read-only accessor, did you mean add_columns()?"
216 ) if (@_ > 1);
701da8c4 217 return @{$self->{_ordered_columns}||[]};
571dced3 218}
219
002a359a 220=head2 remove_columns
221
222 $table->remove_columns(qw/col1 col2 col3/);
223
224Removes columns from the result source.
225
226=head2 remove_column
227
228 $table->remove_column('col');
229
230Convenience alias to remove_columns.
231
232=cut
233
234sub remove_columns {
235 my ($self, @cols) = @_;
236
237 return unless $self->_ordered_columns;
238
239 my $columns = $self->_columns;
240 my @remaining;
241
242 foreach my $col (@{$self->_ordered_columns}) {
243 push @remaining, $col unless grep(/$col/, @cols);
244 }
245
246 foreach (@cols) {
247 undef $columns->{$_};
248 };
249
250 $self->_ordered_columns(\@remaining);
251}
252
253*remove_column = \&remove_columns;
254
87c4e602 255=head2 set_primary_key
256
27f01d1f 257=over 4
258
ebc77b53 259=item Arguments: @cols
27f01d1f 260
261=back
87f0da6a 262
9c992ba1 263Defines one or more columns as primary key for this source. Should be
264called after C<add_columns>.
87f0da6a 265
266Additionally, defines a unique constraint named C<primary>.
267
988bf309 268The primary key columns are used by L<DBIx::Class::PK::Auto> to
75d07914 269retrieve automatically created values from the database.
988bf309 270
87f0da6a 271=cut
9c992ba1 272
273sub set_primary_key {
274 my ($self, @cols) = @_;
275 # check if primary key columns are valid columns
8e04bf91 276 foreach my $col (@cols) {
277 $self->throw_exception("No such column $col on table " . $self->name)
278 unless $self->has_column($col);
9c992ba1 279 }
280 $self->_primaries(\@cols);
87f0da6a 281
282 $self->add_unique_constraint(primary => \@cols);
9c992ba1 283}
284
87f0da6a 285=head2 primary_columns
286
9c992ba1 287Read-only accessor which returns the list of primary keys.
30126ac7 288
87f0da6a 289=cut
9c992ba1 290
291sub primary_columns {
292 return @{shift->_primaries||[]};
293}
294
87f0da6a 295=head2 add_unique_constraint
296
297Declare a unique constraint on this source. Call once for each unique
58b5bb8c 298constraint.
27f01d1f 299
300 # For UNIQUE (column1, column2)
301 __PACKAGE__->add_unique_constraint(
302 constraint_name => [ qw/column1 column2/ ],
303 );
87f0da6a 304
368a5228 305Alternatively, you can specify only the columns:
306
307 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
308
309This will result in a unique constraint named C<table_column1_column2>, where
310C<table> is replaced with the table name.
311
58b5bb8c 312Unique constraints are used, for example, when you call
313L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
314
87f0da6a 315=cut
316
317sub add_unique_constraint {
368a5228 318 my $self = shift;
319 my $cols = pop @_;
320 my $name = shift;
321
322 $name ||= $self->name_unique_constraint($cols);
87f0da6a 323
8e04bf91 324 foreach my $col (@$cols) {
325 $self->throw_exception("No such column $col on table " . $self->name)
326 unless $self->has_column($col);
87f0da6a 327 }
328
329 my %unique_constraints = $self->unique_constraints;
330 $unique_constraints{$name} = $cols;
331 $self->_unique_constraints(\%unique_constraints);
332}
333
d9c74322 334=head2 name_unique_constraint
368a5228 335
336Return a name for a unique constraint containing the specified columns. These
337names consist of the table name and each column name, separated by underscores.
338
339For example, a constraint on a table named C<cd> containing the columns
340C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
341
342=cut
343
344sub name_unique_constraint {
345 my ($self, $cols) = @_;
346
347 return join '_', $self->name, @$cols;
348}
349
87f0da6a 350=head2 unique_constraints
351
352Read-only accessor which returns the list of unique constraints on this source.
353
354=cut
355
356sub unique_constraints {
357 return %{shift->_unique_constraints||{}};
358}
359
e6a0e17c 360=head2 unique_constraint_names
361
362Returns the list of unique constraint names defined on this source.
363
364=cut
365
366sub unique_constraint_names {
367 my ($self) = @_;
368
369 my %unique_constraints = $self->unique_constraints;
370
371 return keys %unique_constraints;
372}
373
374=head2 unique_constraint_columns
375
376Returns the list of columns that make up the specified unique constraint.
377
378=cut
379
380sub unique_constraint_columns {
381 my ($self, $constraint_name) = @_;
382
383 my %unique_constraints = $self->unique_constraints;
384
385 $self->throw_exception(
386 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
387 ) unless exists $unique_constraints{$constraint_name};
388
389 return @{ $unique_constraints{$constraint_name} };
390}
391
9c992ba1 392=head2 from
393
394Returns an expression of the source to be supplied to storage to specify
2053ab2a 395retrieval from this source. In the case of a database, the required FROM
396clause contents.
9c992ba1 397
f9b7bd6e 398=head2 schema
399
400Returns the L<DBIx::Class::Schema> object that this result source
401belongs too.
9c992ba1 402
403=head2 storage
404
75d07914 405Returns the storage handle for the current schema.
988bf309 406
407See also: L<DBIx::Class::Storage>
9c992ba1 408
409=cut
410
411sub storage { shift->schema->storage; }
412
8452e496 413=head2 add_relationship
414
415 $source->add_relationship('relname', 'related_source', $cond, $attrs);
416
24d67825 417The relationship name can be arbitrary, but must be unique for each
418relationship attached to this result source. 'related_source' should
419be the name with which the related result source was registered with
420the current schema. For example:
8452e496 421
24d67825 422 $schema->source('Book')->add_relationship('reviews', 'Review', {
423 'foreign.book_id' => 'self.id',
424 });
425
2053ab2a 426The condition C<$cond> needs to be an L<SQL::Abstract>-style
24d67825 427representation of the join between the tables. For example, if you're
428creating a rel from Author to Book,
988bf309 429
430 { 'foreign.author_id' => 'self.id' }
431
432will result in the JOIN clause
433
434 author me JOIN book foreign ON foreign.author_id = me.id
435
8452e496 436You can specify as many foreign => self mappings as necessary.
437
988bf309 438Valid attributes are as follows:
439
440=over 4
441
442=item join_type
443
444Explicitly specifies the type of join to use in the relationship. Any
445SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
446the SQL command immediately before C<JOIN>.
447
448=item proxy
449
24d67825 450An arrayref containing a list of accessors in the foreign class to proxy in
451the main class. If, for example, you do the following:
002a359a 452
24d67825 453 CD->might_have(liner_notes => 'LinerNotes', undef, {
454 proxy => [ qw/notes/ ],
455 });
002a359a 456
24d67825 457Then, assuming LinerNotes has an accessor named notes, you can do:
988bf309 458
24d67825 459 my $cd = CD->find(1);
2053ab2a 460 # set notes -- LinerNotes object is created if it doesn't exist
461 $cd->notes('Notes go here');
988bf309 462
463=item accessor
464
465Specifies the type of accessor that should be created for the
75d07914 466relationship. Valid values are C<single> (for when there is only a single
467related object), C<multi> (when there can be many), and C<filter> (for
468when there is a single related object, but you also want the relationship
469accessor to double as a column accessor). For C<multi> accessors, an
470add_to_* method is also created, which calls C<create_related> for the
988bf309 471relationship.
472
8452e496 473=back
474
475=cut
476
477sub add_relationship {
478 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
27f01d1f 479 $self->throw_exception("Can't create relationship without join condition")
480 unless $cond;
8452e496 481 $attrs ||= {};
87772e46 482
8452e496 483 my %rels = %{ $self->_relationships };
484 $rels{$rel} = { class => $f_source_name,
87772e46 485 source => $f_source_name,
8452e496 486 cond => $cond,
487 attrs => $attrs };
488 $self->_relationships(\%rels);
489
30126ac7 490 return $self;
87772e46 491
953a18ef 492 # XXX disabled. doesn't work properly currently. skip in tests.
493
8452e496 494 my $f_source = $self->schema->source($f_source_name);
495 unless ($f_source) {
c037c03a 496 $self->ensure_class_loaded($f_source_name);
8452e496 497 $f_source = $f_source_name->result_source;
87772e46 498 #my $s_class = ref($self->schema);
499 #$f_source_name =~ m/^${s_class}::(.*)$/;
500 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
501 #$f_source = $self->schema->source($f_source_name);
8452e496 502 }
503 return unless $f_source; # Can't test rel without f_source
504
505 eval { $self->resolve_join($rel, 'me') };
506
507 if ($@) { # If the resolve failed, back out and re-throw the error
75d07914 508 delete $rels{$rel}; #
8452e496 509 $self->_relationships(\%rels);
701da8c4 510 $self->throw_exception("Error creating relationship $rel: $@");
8452e496 511 }
512 1;
513}
514
87c4e602 515=head2 relationships
8452e496 516
2053ab2a 517Returns all relationship names for this source.
8452e496 518
519=cut
520
521sub relationships {
522 return keys %{shift->_relationships};
523}
524
87c4e602 525=head2 relationship_info
526
27f01d1f 527=over 4
528
ebc77b53 529=item Arguments: $relname
27f01d1f 530
531=back
8452e496 532
2053ab2a 533Returns a hash of relationship information for the specified relationship
534name.
8452e496 535
536=cut
537
538sub relationship_info {
539 my ($self, $rel) = @_;
540 return $self->_relationships->{$rel};
75d07914 541}
8452e496 542
87c4e602 543=head2 has_relationship
544
27f01d1f 545=over 4
546
ebc77b53 547=item Arguments: $rel
27f01d1f 548
549=back
953a18ef 550
2053ab2a 551Returns true if the source has a relationship of this name, false otherwise.
988bf309 552
553=cut
953a18ef 554
555sub has_relationship {
556 my ($self, $rel) = @_;
557 return exists $self->_relationships->{$rel};
558}
559
de60a93d 560=head2 reverse_relationship_info
561
562=over 4
563
564=item Arguments: $relname
565
566=back
567
bab77431 568Returns an array of hash references of relationship information for
de60a93d 569the other side of the specified relationship name.
570
571=cut
572
573sub reverse_relationship_info {
574 my ($self, $rel) = @_;
575 my $rel_info = $self->relationship_info($rel);
576 my $ret = {};
577
578 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
579
580 my @cond = keys(%{$rel_info->{cond}});
581 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
582 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
bab77431 583
de60a93d 584 # Get the related result source for this relationship
585 my $othertable = $self->related_source($rel);
586
587 # Get all the relationships for that source that related to this source
588 # whose foreign column set are our self columns on $rel and whose self
bab77431 589 # columns are our foreign columns on $rel.
de60a93d 590 my @otherrels = $othertable->relationships();
591 my $otherrelationship;
592 foreach my $otherrel (@otherrels) {
593 my $otherrel_info = $othertable->relationship_info($otherrel);
594
595 my $back = $othertable->related_source($otherrel);
596 next unless $back->name eq $self->name;
597
598 my @othertestconds;
599
600 if (ref $otherrel_info->{cond} eq 'HASH') {
601 @othertestconds = ($otherrel_info->{cond});
602 }
603 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
604 @othertestconds = @{$otherrel_info->{cond}};
605 }
606 else {
607 next;
608 }
609
610 foreach my $othercond (@othertestconds) {
611 my @other_cond = keys(%$othercond);
612 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
613 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
bab77431 614 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
de60a93d 615 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
616 $ret->{$otherrel} = $otherrel_info;
617 }
618 }
619 return $ret;
620}
621
622=head2 compare_relationship_keys
623
624=over 4
625
626=item Arguments: $keys1, $keys2
627
628=back
629
630Returns true if both sets of keynames are the same, false otherwise.
631
632=cut
633
634sub compare_relationship_keys {
635 my ($self, $keys1, $keys2) = @_;
636
637 # Make sure every keys1 is in keys2
638 my $found;
639 foreach my $key (@$keys1) {
640 $found = 0;
641 foreach my $prim (@$keys2) {
642 if ($prim eq $key) {
643 $found = 1;
644 last;
645 }
646 }
647 last unless $found;
648 }
649
650 # Make sure every key2 is in key1
651 if ($found) {
652 foreach my $prim (@$keys2) {
653 $found = 0;
654 foreach my $key (@$keys1) {
655 if ($prim eq $key) {
656 $found = 1;
657 last;
658 }
659 }
660 last unless $found;
661 }
662 }
663
664 return $found;
665}
666
87c4e602 667=head2 resolve_join
668
27f01d1f 669=over 4
670
ebc77b53 671=item Arguments: $relation
27f01d1f 672
673=back
8452e496 674
2053ab2a 675Returns the join structure required for the related result source.
8452e496 676
677=cut
678
679sub resolve_join {
489709af 680 my ($self, $join, $alias, $seen) = @_;
681 $seen ||= {};
87772e46 682 if (ref $join eq 'ARRAY') {
489709af 683 return map { $self->resolve_join($_, $alias, $seen) } @$join;
87772e46 684 } elsif (ref $join eq 'HASH') {
489709af 685 return
887ce227 686 map {
687 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
688 ($self->resolve_join($_, $alias, $seen),
689 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
690 } keys %$join;
87772e46 691 } elsif (ref $join) {
701da8c4 692 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
87772e46 693 } else {
489709af 694 my $count = ++$seen->{$join};
695 #use Data::Dumper; warn Dumper($seen);
696 my $as = ($count > 1 ? "${join}_${count}" : $join);
3842b955 697 my $rel_info = $self->relationship_info($join);
701da8c4 698 $self->throw_exception("No such relationship ${join}") unless $rel_info;
3842b955 699 my $type = $rel_info->{attrs}{join_type} || '';
489709af 700 return [ { $as => $self->related_source($join)->from,
953a18ef 701 -join_type => $type },
489709af 702 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
953a18ef 703 }
704}
705
87c4e602 706=head2 resolve_condition
707
27f01d1f 708=over 4
709
ebc77b53 710=item Arguments: $cond, $as, $alias|$object
27f01d1f 711
712=back
953a18ef 713
3842b955 714Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef 715returns a join condition; if given an object, inverts that object to produce
716a related conditional from that object.
717
718=cut
719
720sub resolve_condition {
489709af 721 my ($self, $cond, $as, $for) = @_;
953a18ef 722 #warn %$cond;
723 if (ref $cond eq 'HASH') {
724 my %ret;
bd054cb4 725 foreach my $k (keys %{$cond}) {
726 my $v = $cond->{$k};
953a18ef 727 # XXX should probably check these are valid columns
27f01d1f 728 $k =~ s/^foreign\.// ||
75d07914 729 $self->throw_exception("Invalid rel cond key ${k}");
27f01d1f 730 $v =~ s/^self\.// ||
75d07914 731 $self->throw_exception("Invalid rel cond val ${v}");
953a18ef 732 if (ref $for) { # Object
3842b955 733 #warn "$self $k $for $v";
734 $ret{$k} = $for->get_column($v);
735 #warn %ret;
2c037e6b 736 } elsif (!defined $for) { # undef, i.e. "no object"
737 $ret{$k} = undef;
fde6e28e 738 } elsif (ref $as) { # reverse object
739 $ret{$v} = $as->get_column($k);
2c037e6b 740 } elsif (!defined $as) { # undef, i.e. "no reverse object"
741 $ret{$v} = undef;
953a18ef 742 } else {
489709af 743 $ret{"${as}.${k}"} = "${for}.${v}";
953a18ef 744 }
953a18ef 745 }
746 return \%ret;
5efe4c79 747 } elsif (ref $cond eq 'ARRAY') {
489709af 748 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
953a18ef 749 } else {
750 die("Can't handle this yet :(");
87772e46 751 }
752}
753
87c4e602 754=head2 resolve_prefetch
755
27f01d1f 756=over 4
757
ebc77b53 758=item Arguments: hashref/arrayref/scalar
27f01d1f 759
760=back
988bf309 761
b3e8ac9b 762Accepts one or more relationships for the current source and returns an
763array of column names for each of those relationships. Column names are
764prefixed relative to the current source, in accordance with where they appear
765in the supplied relationships. Examples:
766
5ac6a044 767 my $source = $schema->resultset('Tag')->source;
b3e8ac9b 768 @columns = $source->resolve_prefetch( { cd => 'artist' } );
769
770 # @columns =
771 #(
772 # 'cd.cdid',
773 # 'cd.artist',
774 # 'cd.title',
775 # 'cd.year',
776 # 'cd.artist.artistid',
777 # 'cd.artist.name'
778 #)
779
780 @columns = $source->resolve_prefetch( qw[/ cd /] );
781
782 # @columns =
783 #(
784 # 'cd.cdid',
785 # 'cd.artist',
786 # 'cd.title',
787 # 'cd.year'
788 #)
789
790 $source = $schema->resultset('CD')->source;
791 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
792
793 # @columns =
794 #(
795 # 'artist.artistid',
796 # 'artist.name',
797 # 'producer.producerid',
798 # 'producer.name'
75d07914 799 #)
988bf309 800
b3e8ac9b 801=cut
802
803sub resolve_prefetch {
0f66a01b 804 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
489709af 805 $seen ||= {};
b3e8ac9b 806 #$alias ||= $self->name;
807 #warn $alias, Dumper $pre;
808 if( ref $pre eq 'ARRAY' ) {
0f66a01b 809 return
810 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
811 @$pre;
b3e8ac9b 812 }
813 elsif( ref $pre eq 'HASH' ) {
814 my @ret =
815 map {
0f66a01b 816 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
489709af 817 $self->related_source($_)->resolve_prefetch(
0f66a01b 818 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
819 } keys %$pre;
b3e8ac9b 820 #die Dumper \@ret;
821 return @ret;
822 }
823 elsif( ref $pre ) {
a86b1efe 824 $self->throw_exception(
825 "don't know how to resolve prefetch reftype ".ref($pre));
b3e8ac9b 826 }
827 else {
489709af 828 my $count = ++$seen->{$pre};
829 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
b3e8ac9b 830 my $rel_info = $self->relationship_info( $pre );
a86b1efe 831 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
832 unless $rel_info;
37f23589 833 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
a86b1efe 834 my $rel_source = $self->related_source($pre);
0f66a01b 835
836 if (exists $rel_info->{attrs}{accessor}
837 && $rel_info->{attrs}{accessor} eq 'multi') {
838 $self->throw_exception(
839 "Can't prefetch has_many ${pre} (join cond too complex)")
840 unless ref($rel_info->{cond}) eq 'HASH';
37f23589 841 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
0f66a01b 842 keys %{$rel_info->{cond}};
843 $collapse->{"${as_prefix}${pre}"} = \@key;
5a5bec6c 844 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
845 ? @{$rel_info->{attrs}{order_by}}
846 : (defined $rel_info->{attrs}{order_by}
847 ? ($rel_info->{attrs}{order_by})
848 : ()));
849 push(@$order, map { "${as}.$_" } (@key, @ord));
0f66a01b 850 }
851
489709af 852 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
a86b1efe 853 $rel_source->columns;
b3e8ac9b 854 #warn $alias, Dumper (\@ret);
489709af 855 #return @ret;
b3e8ac9b 856 }
857}
953a18ef 858
87c4e602 859=head2 related_source
860
27f01d1f 861=over 4
862
ebc77b53 863=item Arguments: $relname
27f01d1f 864
865=back
87772e46 866
2053ab2a 867Returns the result source object for the given relationship.
87772e46 868
869=cut
870
871sub related_source {
872 my ($self, $rel) = @_;
aea52c85 873 if( !$self->has_relationship( $rel ) ) {
701da8c4 874 $self->throw_exception("No such relationship '$rel'");
aea52c85 875 }
87772e46 876 return $self->schema->source($self->relationship_info($rel)->{source});
8452e496 877}
878
77254782 879=head2 related_class
880
27f01d1f 881=over 4
882
ebc77b53 883=item Arguments: $relname
27f01d1f 884
885=back
77254782 886
2053ab2a 887Returns the class name for objects in the given relationship.
77254782 888
889=cut
890
891sub related_class {
892 my ($self, $rel) = @_;
893 if( !$self->has_relationship( $rel ) ) {
894 $self->throw_exception("No such relationship '$rel'");
895 }
896 return $self->schema->class($self->relationship_info($rel)->{source});
897}
898
5ac6a044 899=head2 resultset
900
bcc5a210 901Returns a resultset for the given source. This will initially be created
902on demand by calling
5ac6a044 903
988bf309 904 $self->resultset_class->new($self, $self->resultset_attributes)
5ac6a044 905
bcc5a210 906but is cached from then on unless resultset_class changes.
907
5ac6a044 908=head2 resultset_class
909
988bf309 910Set the class of the resultset, this is useful if you want to create your
911own resultset methods. Create your own class derived from
912L<DBIx::Class::ResultSet>, and set it here.
5ac6a044 913
914=head2 resultset_attributes
915
988bf309 916Specify here any attributes you wish to pass to your specialised resultset.
5ac6a044 917
918=cut
919
920sub resultset {
921 my $self = shift;
27f01d1f 922 $self->throw_exception(
923 'resultset does not take any arguments. If you want another resultset, '.
924 'call it on the schema instead.'
925 ) if scalar @_;
428c2b82 926
927 # disabled until we can figure out a way to do it without consistency issues
928 #
929 #return $self->{_resultset}
930 # if ref $self->{_resultset} eq $self->resultset_class;
931 #return $self->{_resultset} =
932
933 return $self->resultset_class->new(
27f01d1f 934 $self, $self->{resultset_attributes}
935 );
5ac6a044 936}
937
bab77431 938=head2 source_name
939
940=over 4
941
942=item Arguments: $source_name
943
944=back
945
946Set the name of the result source when it is loaded into a schema.
947This is usefull if you want to refer to a result source by a name other than
948its class name.
949
950 package ArchivedBooks;
951 use base qw/DBIx::Class/;
952 __PACKAGE__->table('books_archive');
953 __PACKAGE__->source_name('Books');
954
955 # from your schema...
956 $schema->resultset('Books')->find(1);
957
701da8c4 958=head2 throw_exception
959
2053ab2a 960See L<DBIx::Class::Schema/"throw_exception">.
701da8c4 961
962=cut
963
964sub throw_exception {
965 my $self = shift;
75d07914 966 if (defined $self->schema) {
701da8c4 967 $self->schema->throw_exception(@_);
968 } else {
969 croak(@_);
970 }
971}
972
9c992ba1 973=head1 AUTHORS
974
975Matt S. Trout <mst@shadowcatsystems.co.uk>
976
977=head1 LICENSE
978
979You may distribute this code under the same terms as Perl itself.
980
981=cut
982