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