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