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