Merge 'bulk_create' into 'DBIx-Class-current'
[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 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
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 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
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 eq 'HASH') { # reverse hashref
775         $ret{$v} = $as->{$k};
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 @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
880       #              values %{$rel_info->{cond}};
881       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
882         # action at a distance. prepending the '.' allows simpler code
883         # in ResultSet->_collapse_result
884       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
885                     keys %{$rel_info->{cond}};
886       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
887                    ? @{$rel_info->{attrs}{order_by}}
888                    : (defined $rel_info->{attrs}{order_by}
889                        ? ($rel_info->{attrs}{order_by})
890                        : ()));
891       push(@$order, map { "${as}.$_" } (@key, @ord));
892     }
893
894     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
895       $rel_source->columns;
896     #warn $alias, Dumper (\@ret);
897     #return @ret;
898   }
899 }
900
901 =head2 related_source
902
903 =over 4
904
905 =item Arguments: $relname
906
907 =back
908
909 Returns the result source object for the given relationship.
910
911 =cut
912
913 sub related_source {
914   my ($self, $rel) = @_;
915   if( !$self->has_relationship( $rel ) ) {
916     $self->throw_exception("No such relationship '$rel'");
917   }
918   return $self->schema->source($self->relationship_info($rel)->{source});
919 }
920
921 =head2 related_class
922
923 =over 4
924
925 =item Arguments: $relname
926
927 =back
928
929 Returns the class name for objects in the given relationship.
930
931 =cut
932
933 sub related_class {
934   my ($self, $rel) = @_;
935   if( !$self->has_relationship( $rel ) ) {
936     $self->throw_exception("No such relationship '$rel'");
937   }
938   return $self->schema->class($self->relationship_info($rel)->{source});
939 }
940
941 =head2 resultset
942
943 Returns a resultset for the given source. This will initially be created
944 on demand by calling
945
946   $self->resultset_class->new($self, $self->resultset_attributes)
947
948 but is cached from then on unless resultset_class changes.
949
950 =head2 resultset_class
951
952 ` package My::ResultSetClass;
953   use base 'DBIx::Class::ResultSet';
954   ...
955
956   $source->resultset_class('My::ResultSet::Class');
957
958 Set the class of the resultset, this is useful if you want to create your
959 own resultset methods. Create your own class derived from
960 L<DBIx::Class::ResultSet>, and set it here. 
961
962 =head2 resultset_attributes
963
964   $source->resultset_attributes({ order_by => [ 'id' ] });
965
966 Specify here any attributes you wish to pass to your specialised
967 resultset. For a full list of these, please see
968 L<DBIx::Class::ResultSet/ATTRIBUTES>.
969
970 =cut
971
972 sub resultset {
973   my $self = shift;
974   $self->throw_exception(
975     'resultset does not take any arguments. If you want another resultset, '.
976     'call it on the schema instead.'
977   ) if scalar @_;
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
1043 1;