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