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