Typo in scalar ref example
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / ResultSource.pm
1 package DBIx::Class::ResultSource;
2
3 use strict;
4 use warnings;
5
6 use DBIx::Class::ResultSet;
7 use Carp::Clan qw/^DBIx::Class/;
8 use Storable;
9
10 use base qw/DBIx::Class/;
11 __PACKAGE__->load_components(qw/AccessorGroup/);
12
13 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
14   _columns _primaries _unique_constraints name resultset_attributes
15   schema from _relationships source_name/);
16
17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
18   result_class/);
19
20 =head1 NAME
21
22 DBIx::Class::ResultSource - Result source object
23
24 =head1 SYNOPSIS
25
26 =head1 DESCRIPTION
27
28 A ResultSource is a component of a schema from which results can be directly
29 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
30
31 =head1 METHODS
32
33 =pod
34
35 =head2 new
36
37   $class->new();
38
39   $class->new({attribute_name => value});
40
41 Creates a new ResultSource object.  Not normally called directly by end users.
42
43 =cut
44
45 sub new {
46   my ($class, $attrs) = @_;
47   $class = ref $class if ref $class;
48
49   my $new = { %{$attrs || {}}, _resultset => undef };
50   bless $new, $class;
51
52   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
53   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
54   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
55   $new->{_columns} = { %{$new->{_columns}||{}} };
56   $new->{_relationships} = { %{$new->{_relationships}||{}} };
57   $new->{name} ||= "!!NAME NOT SET!!";
58   $new->{_columns_info_loaded} ||= 0;
59   return $new;
60 }
61
62 =pod
63
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
70 Adds columns to the result source. If supplied key => hashref pairs, uses
71 the hashref as the column_info for that column. Repeated calls of this
72 method will add more columns, not replace them.
73
74 The contents of the column_info are not set in stone. The following
75 keys are currently recognised/used by DBIx::Class:
76
77 =over 4
78
79 =item accessor
80
81 Use this to set the name of the accessor for this column. If unset,
82 the name of the column will be used.
83
84 =item data_type
85
86 This contains the column type. It is automatically filled by the
87 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
88 L<DBIx::Class::Schema::Loader> module. If you do not enter a
89 data_type, DBIx::Class will attempt to retrieve it from the
90 database for you, using L<DBI>'s column_info method. The values of this
91 key are typically upper-cased.
92
93 Currently there is no standard set of values for the data_type. Use
94 whatever your database supports.
95
96 =item size
97
98 The length of your column, if it is a column type that can have a size
99 restriction. This is currently not used by DBIx::Class.
100
101 =item is_nullable
102
103 Set this to a true value for a columns that is allowed to contain
104 NULL values. This is currently not used by DBIx::Class.
105
106 =item is_auto_increment
107
108 Set this to a true value for a column whose value is somehow
109 automatically set. This is used to determine which columns to empty
110 when cloning objects using C<copy>.
111
112 =item is_foreign_key
113
114 Set this to a true value for a column that contains a key from a
115 foreign table. This is currently not used by DBIx::Class.
116
117 =item default_value
118
119 Set this to the default value which will be inserted into a column
120 by the database. Can contain either a value or a function. This is
121 currently not used by DBIx::Class.
122
123 =item sequence
124
125 Set this on a primary key column to the name of the sequence used to
126 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
127 will attempt to retrieve the name of the sequence from the database
128 automatically.
129
130 =back
131
132 =head2 add_column
133
134   $table->add_column('col' => \%info?);
135
136 Convenience alias to add_columns.
137
138 =cut
139
140 sub add_columns {
141   my ($self, @cols) = @_;
142   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
143
144   my @added;
145   my $columns = $self->_columns;
146   while (my $col = shift @cols) {
147     # If next entry is { ... } use that for the column info, if not
148     # use an empty hashref
149     my $column_info = ref $cols[0] ? shift(@cols) : {};
150     push(@added, $col) unless exists $columns->{$col};
151     $columns->{$col} = $column_info;
152   }
153   push @{ $self->_ordered_columns }, @added;
154   return $self;
155 }
156
157 *add_column = \&add_columns;
158
159 =head2 has_column
160
161   if ($obj->has_column($col)) { ... }
162
163 Returns true if the source has a column of this name, false otherwise.
164
165 =cut
166
167 sub has_column {
168   my ($self, $column) = @_;
169   return exists $self->_columns->{$column};
170 }
171
172 =head2 column_info
173
174   my $info = $obj->column_info($col);
175
176 Returns the column metadata hashref for a column. See the description
177 of add_column for information on the contents of the hashref.
178
179 =cut
180
181 sub column_info {
182   my ($self, $column) = @_;
183   $self->throw_exception("No such column $column")
184     unless exists $self->_columns->{$column};
185   #warn $self->{_columns_info_loaded}, "\n";
186   if ( ! $self->_columns->{$column}{data_type}
187        and ! $self->{_columns_info_loaded}
188        and $self->schema and $self->storage )
189   {
190     $self->{_columns_info_loaded}++;
191     my $info;
192     my $lc_info;
193     # eval for the case of storage without table
194     eval { $info = $self->storage->columns_info_for( $self->from ) };
195     unless ($@) {
196       for my $realcol ( keys %{$info} ) {
197         $lc_info->{lc $realcol} = $info->{$realcol};
198       }
199       foreach my $col ( keys %{$self->_columns} ) {
200         $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
201       }
202     }
203   }
204   return $self->_columns->{$column};
205 }
206
207 =head2 columns
208
209   my @column_names = $obj->columns;
210
211 Returns all column names in the order they were declared to add_columns.
212
213 =cut
214
215 sub columns {
216   my $self = shift;
217   $self->throw_exception(
218     "columns() is a read-only accessor, did you mean add_columns()?"
219   ) if (@_ > 1);
220   return @{$self->{_ordered_columns}||[]};
221 }
222
223 =head2 remove_columns
224
225   $table->remove_columns(qw/col1 col2 col3/);
226
227 Removes columns from the result source.
228
229 =head2 remove_column
230
231   $table->remove_column('col');
232
233 Convenience alias to remove_columns.
234
235 =cut
236
237 sub 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
258 =head2 set_primary_key
259
260 =over 4
261
262 =item Arguments: @cols
263
264 =back
265
266 Defines one or more columns as primary key for this source. Should be
267 called after C<add_columns>.
268
269 Additionally, defines a unique constraint named C<primary>.
270
271 The primary key columns are used by L<DBIx::Class::PK::Auto> to
272 retrieve automatically created values from the database.
273
274 =cut
275
276 sub set_primary_key {
277   my ($self, @cols) = @_;
278   # check if primary key columns are valid columns
279   foreach my $col (@cols) {
280     $self->throw_exception("No such column $col on table " . $self->name)
281       unless $self->has_column($col);
282   }
283   $self->_primaries(\@cols);
284
285   $self->add_unique_constraint(primary => \@cols);
286 }
287
288 =head2 primary_columns
289
290 Read-only accessor which returns the list of primary keys.
291
292 =cut
293
294 sub primary_columns {
295   return @{shift->_primaries||[]};
296 }
297
298 =head2 add_unique_constraint
299
300 Declare a unique constraint on this source. Call once for each unique
301 constraint.
302
303   # For UNIQUE (column1, column2)
304   __PACKAGE__->add_unique_constraint(
305     constraint_name => [ qw/column1 column2/ ],
306   );
307
308 Alternatively, you can specify only the columns:
309
310   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
311
312 This will result in a unique constraint named C<table_column1_column2>, where
313 C<table> is replaced with the table name.
314
315 Unique constraints are used, for example, when you call
316 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
317
318 =cut
319
320 sub add_unique_constraint {
321   my $self = shift;
322   my $cols = pop @_;
323   my $name = shift;
324
325   $name ||= $self->name_unique_constraint($cols);
326
327   foreach my $col (@$cols) {
328     $self->throw_exception("No such column $col on table " . $self->name)
329       unless $self->has_column($col);
330   }
331
332   my %unique_constraints = $self->unique_constraints;
333   $unique_constraints{$name} = $cols;
334   $self->_unique_constraints(\%unique_constraints);
335 }
336
337 =head2 name_unique_constraint
338
339 Return a name for a unique constraint containing the specified columns. These
340 names consist of the table name and each column name, separated by underscores.
341
342 For example, a constraint on a table named C<cd> containing the columns
343 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
344
345 =cut
346
347 sub name_unique_constraint {
348   my ($self, $cols) = @_;
349
350   return join '_', $self->name, @$cols;
351 }
352
353 =head2 unique_constraints
354
355 Read-only accessor which returns the list of unique constraints on this source.
356
357 =cut
358
359 sub unique_constraints {
360   return %{shift->_unique_constraints||{}};
361 }
362
363 =head2 unique_constraint_names
364
365 Returns the list of unique constraint names defined on this source.
366
367 =cut
368
369 sub 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
379 Returns the list of columns that make up the specified unique constraint.
380
381 =cut
382
383 sub 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
395 =head2 from
396
397 Returns an expression of the source to be supplied to storage to specify
398 retrieval from this source. In the case of a database, the required FROM
399 clause contents.
400
401 =head2 schema
402
403 Returns the L<DBIx::Class::Schema> object that this result source 
404 belongs too.
405
406 =head2 storage
407
408 Returns the storage handle for the current schema.
409
410 See also: L<DBIx::Class::Storage>
411
412 =cut
413
414 sub storage { shift->schema->storage; }
415
416 =head2 add_relationship
417
418   $source->add_relationship('relname', 'related_source', $cond, $attrs);
419
420 The relationship name can be arbitrary, but must be unique for each
421 relationship attached to this result source. 'related_source' should
422 be the name with which the related result source was registered with
423 the current schema. For example:
424
425   $schema->source('Book')->add_relationship('reviews', 'Review', {
426     'foreign.book_id' => 'self.id',
427   });
428
429 The condition C<$cond> needs to be an L<SQL::Abstract>-style
430 representation of the join between the tables. For example, if you're
431 creating a rel from Author to Book,
432
433   { 'foreign.author_id' => 'self.id' }
434
435 will result in the JOIN clause
436
437   author me JOIN book foreign ON foreign.author_id = me.id
438
439 You can specify as many foreign => self mappings as necessary.
440
441 Valid attributes are as follows:
442
443 =over 4
444
445 =item join_type
446
447 Explicitly specifies the type of join to use in the relationship. Any
448 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
449 the SQL command immediately before C<JOIN>.
450
451 =item proxy
452
453 An arrayref containing a list of accessors in the foreign class to proxy in
454 the main class. If, for example, you do the following:
455
456   CD->might_have(liner_notes => 'LinerNotes', undef, {
457     proxy => [ qw/notes/ ],
458   });
459
460 Then, assuming LinerNotes has an accessor named notes, you can do:
461
462   my $cd = CD->find(1);
463   # set notes -- LinerNotes object is created if it doesn't exist
464   $cd->notes('Notes go here');
465
466 =item accessor
467
468 Specifies the type of accessor that should be created for the
469 relationship. Valid values are C<single> (for when there is only a single
470 related object), C<multi> (when there can be many), and C<filter> (for
471 when there is a single related object, but you also want the relationship
472 accessor to double as a column accessor). For C<multi> accessors, an
473 add_to_* method is also created, which calls C<create_related> for the
474 relationship.
475
476 =back
477
478 =cut
479
480 sub add_relationship {
481   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
482   $self->throw_exception("Can't create relationship without join condition")
483     unless $cond;
484   $attrs ||= {};
485
486   my %rels = %{ $self->_relationships };
487   $rels{$rel} = { class => $f_source_name,
488                   source => $f_source_name,
489                   cond  => $cond,
490                   attrs => $attrs };
491   $self->_relationships(\%rels);
492
493   return $self;
494
495   # XXX disabled. doesn't work properly currently. skip in tests.
496
497   my $f_source = $self->schema->source($f_source_name);
498   unless ($f_source) {
499     $self->ensure_class_loaded($f_source_name);
500     $f_source = $f_source_name->result_source;
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);
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
511     delete $rels{$rel}; #
512     $self->_relationships(\%rels);
513     $self->throw_exception("Error creating relationship $rel: $@");
514   }
515   1;
516 }
517
518 =head2 relationships
519
520 Returns all relationship names for this source.
521
522 =cut
523
524 sub relationships {
525   return keys %{shift->_relationships};
526 }
527
528 =head2 relationship_info
529
530 =over 4
531
532 =item Arguments: $relname
533
534 =back
535
536 Returns a hash of relationship information for the specified relationship
537 name.
538
539 =cut
540
541 sub relationship_info {
542   my ($self, $rel) = @_;
543   return $self->_relationships->{$rel};
544 }
545
546 =head2 has_relationship
547
548 =over 4
549
550 =item Arguments: $rel
551
552 =back
553
554 Returns true if the source has a relationship of this name, false otherwise.
555
556 =cut
557
558 sub has_relationship {
559   my ($self, $rel) = @_;
560   return exists $self->_relationships->{$rel};
561 }
562
563 =head2 reverse_relationship_info
564
565 =over 4
566
567 =item Arguments: $relname
568
569 =back
570
571 Returns an array of hash references of relationship information for
572 the other side of the specified relationship name.
573
574 =cut
575
576 sub 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;
586
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
592   # columns are our foreign columns on $rel.
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;
617       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
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
633 Returns true if both sets of keynames are the same, false otherwise.
634
635 =cut
636
637 sub 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
670 =head2 resolve_join
671
672 =over 4
673
674 =item Arguments: $relation
675
676 =back
677
678 Returns the join structure required for the related result source.
679
680 =cut
681
682 sub resolve_join {
683   my ($self, $join, $alias, $seen) = @_;
684   $seen ||= {};
685   if (ref $join eq 'ARRAY') {
686     return map { $self->resolve_join($_, $alias, $seen) } @$join;
687   } elsif (ref $join eq 'HASH') {
688     return
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;
694   } elsif (ref $join) {
695     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
696   } else {
697     my $count = ++$seen->{$join};
698     #use Data::Dumper; warn Dumper($seen);
699     my $as = ($count > 1 ? "${join}_${count}" : $join);
700     my $rel_info = $self->relationship_info($join);
701     $self->throw_exception("No such relationship ${join}") unless $rel_info;
702     my $type = $rel_info->{attrs}{join_type} || '';
703     return [ { $as => $self->related_source($join)->from,
704                -join_type => $type },
705              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
706   }
707 }
708
709 =head2 resolve_condition
710
711 =over 4
712
713 =item Arguments: $cond, $as, $alias|$object
714
715 =back
716
717 Resolves the passed condition to a concrete query fragment. If given an alias,
718 returns a join condition; if given an object, inverts that object to produce
719 a related conditional from that object.
720
721 =cut
722
723 sub resolve_condition {
724   my ($self, $cond, $as, $for) = @_;
725   #warn %$cond;
726   if (ref $cond eq 'HASH') {
727     my %ret;
728     foreach my $k (keys %{$cond}) {
729       my $v = $cond->{$k};
730       # XXX should probably check these are valid columns
731       $k =~ s/^foreign\.// ||
732         $self->throw_exception("Invalid rel cond key ${k}");
733       $v =~ s/^self\.// ||
734         $self->throw_exception("Invalid rel cond val ${v}");
735       if (ref $for) { # Object
736         #warn "$self $k $for $v";
737         $ret{$k} = $for->get_column($v);
738         #warn %ret;
739       } elsif (!defined $for) { # undef, i.e. "no object"
740         $ret{$k} = undef;
741       } elsif (ref $as) { # reverse object
742         $ret{$v} = $as->get_column($k);
743       } elsif (!defined $as) { # undef, i.e. "no reverse object"
744         $ret{$v} = undef;
745       } else {
746         $ret{"${as}.${k}"} = "${for}.${v}";
747       }
748     }
749     return \%ret;
750   } elsif (ref $cond eq 'ARRAY') {
751     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
752   } else {
753    die("Can't handle this yet :(");
754   }
755 }
756
757 =head2 resolve_prefetch
758
759 =over 4
760
761 =item Arguments: hashref/arrayref/scalar
762
763 =back
764
765 Accepts one or more relationships for the current source and returns an
766 array of column names for each of those relationships. Column names are
767 prefixed relative to the current source, in accordance with where they appear
768 in the supplied relationships. Examples:
769
770   my $source = $schema->resultset('Tag')->source;
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'
802   #)
803
804 =cut
805
806 sub resolve_prefetch {
807   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
808   $seen ||= {};
809   #$alias ||= $self->name;
810   #warn $alias, Dumper $pre;
811   if( ref $pre eq 'ARRAY' ) {
812     return
813       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
814         @$pre;
815   }
816   elsif( ref $pre eq 'HASH' ) {
817     my @ret =
818     map {
819       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
820       $self->related_source($_)->resolve_prefetch(
821                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
822     } keys %$pre;
823     #die Dumper \@ret;
824     return @ret;
825   }
826   elsif( ref $pre ) {
827     $self->throw_exception(
828       "don't know how to resolve prefetch reftype ".ref($pre));
829   }
830   else {
831     my $count = ++$seen->{$pre};
832     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
833     my $rel_info = $self->relationship_info( $pre );
834     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
835       unless $rel_info;
836     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
837     my $rel_source = $self->related_source($pre);
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';
844       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
845                     keys %{$rel_info->{cond}};
846       $collapse->{"${as_prefix}${pre}"} = \@key;
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));
853     }
854
855     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
856       $rel_source->columns;
857     #warn $alias, Dumper (\@ret);
858     #return @ret;
859   }
860 }
861
862 =head2 related_source
863
864 =over 4
865
866 =item Arguments: $relname
867
868 =back
869
870 Returns the result source object for the given relationship.
871
872 =cut
873
874 sub related_source {
875   my ($self, $rel) = @_;
876   if( !$self->has_relationship( $rel ) ) {
877     $self->throw_exception("No such relationship '$rel'");
878   }
879   return $self->schema->source($self->relationship_info($rel)->{source});
880 }
881
882 =head2 related_class
883
884 =over 4
885
886 =item Arguments: $relname
887
888 =back
889
890 Returns the class name for objects in the given relationship.
891
892 =cut
893
894 sub 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
902 =head2 resultset
903
904 Returns a resultset for the given source. This will initially be created
905 on demand by calling
906
907   $self->resultset_class->new($self, $self->resultset_attributes)
908
909 but is cached from then on unless resultset_class changes.
910
911 =head2 resultset_class
912
913 Set the class of the resultset, this is useful if you want to create your
914 own resultset methods. Create your own class derived from
915 L<DBIx::Class::ResultSet>, and set it here.
916
917 =head2 resultset_attributes
918
919 Specify here any attributes you wish to pass to your specialised resultset.
920
921 =cut
922
923 sub resultset {
924   my $self = shift;
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 @_;
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(
937     $self, $self->{resultset_attributes}
938   );
939 }
940
941 =head2 source_name
942
943 =over 4
944
945 =item Arguments: $source_name
946
947 =back
948
949 Set the name of the result source when it is loaded into a schema.
950 This is usefull if you want to refer to a result source by a name other than
951 its 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
961 =head2 throw_exception
962
963 See L<DBIx::Class::Schema/"throw_exception">.
964
965 =cut
966
967 sub throw_exception {
968   my $self = shift;
969   if (defined $self->schema) {
970     $self->schema->throw_exception(@_);
971   } else {
972     croak(@_);
973   }
974 }
975
976 =head1 AUTHORS
977
978 Matt S. Trout <mst@shadowcatsystems.co.uk>
979
980 =head1 LICENSE
981
982 You may distribute this code under the same terms as Perl itself.
983
984 =cut
985