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