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