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