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