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