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