fd7da0f3c26177888b28bae0622dc8034d863e58
[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 sqlt_deploy_callback/);
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 =cut
37
38 sub new {
39   my ($class, $attrs) = @_;
40   $class = ref $class if ref $class;
41
42   my $new = bless { %{$attrs || {}} }, $class;
43   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
44   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
45   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
46   $new->{_columns} = { %{$new->{_columns}||{}} };
47   $new->{_relationships} = { %{$new->{_relationships}||{}} };
48   $new->{name} ||= "!!NAME NOT SET!!";
49   $new->{_columns_info_loaded} ||= 0;
50   $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
51   return $new;
52 }
53
54 =pod
55
56 =head2 add_columns
57
58 =over
59
60 =item Arguments: @columns
61
62 =item Return value: The ResultSource object
63
64 =back
65
66   $source->add_columns(qw/col1 col2 col3/);
67
68   $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
69
70 Adds columns to the result source. If supplied key => hashref pairs, uses
71 the hashref as the column_info for that column. Repeated calls of this
72 method will add more columns, not replace them.
73
74 The column names given will be created as accessor methods on your
75 L<DBIx::Class::Row> objects, you can change the name of the accessor
76 by supplying an L</accessor> in the column_info hash.
77
78 The contents of the column_info are not set in stone. The following
79 keys are currently recognised/used by DBIx::Class:
80
81 =over 4
82
83 =item accessor
84
85 Use this to set the name of the accessor method for this column. If unset,
86 the name of the column will be used.
87
88 =item data_type
89
90 This contains the column type. It is automatically filled by the
91 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
92 L<DBIx::Class::Schema::Loader> module. If you do not enter a
93 data_type, DBIx::Class will attempt to retrieve it from the
94 database for you, using L<DBI>'s column_info method. The values of this
95 key are typically upper-cased.
96
97 Currently there is no standard set of values for the data_type. Use
98 whatever your database supports.
99
100 =item size
101
102 The length of your column, if it is a column type that can have a size
103 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
104
105 =item is_nullable
106
107 Set this to a true value for a columns that is allowed to contain
108 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
109
110 =item is_auto_increment
111
112 Set this to a true value for a column whose value is somehow
113 automatically set. This is used to determine which columns to empty
114 when cloning objects using C<copy>. It is also used by
115 L<DBIx::Class::Schema/deploy>.
116
117 =item is_foreign_key
118
119 Set this to a true value for a column that contains a key from a
120 foreign table. This is currently only used by
121 L<DBIx::Class::Schema/deploy>.
122
123 =item default_value
124
125 Set this to the default value which will be inserted into a column
126 by the database. Can contain either a value or a function. This is
127 currently only used by L<DBIx::Class::Schema/deploy>.
128
129 =item sequence
130
131 Set this on a primary key column to the name of the sequence used to
132 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
133 will attempt to retrieve the name of the sequence from the database
134 automatically.
135
136 =item auto_nextval
137
138 Set this to a true value for a column whose value is retrieved
139 automatically from an oracle sequence. If you do not use an oracle
140 trigger to get the nextval, you have to set sequence as well.
141
142 =item extra
143
144 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
145 to add extra non-generic data to the column. For example: C<< extra
146 => { unsigned => 1} >> is used by the MySQL producer to set an integer
147 column to unsigned. For more details, see
148 L<SQL::Translator::Producer::MySQL>.
149
150 =back
151
152 =head2 add_column
153
154 =over
155
156 =item Arguments: $colname, [ \%columninfo ]
157
158 =item Return value: 1/0 (true/false)
159
160 =back
161
162   $source->add_column('col' => \%info?);
163
164 Add a single column and optional column info. Uses the same column
165 info keys as L</add_columns>.
166
167 =cut
168
169 sub add_columns {
170   my ($self, @cols) = @_;
171   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
172
173   my @added;
174   my $columns = $self->_columns;
175   while (my $col = shift @cols) {
176     # If next entry is { ... } use that for the column info, if not
177     # use an empty hashref
178     my $column_info = ref $cols[0] ? shift(@cols) : {};
179     push(@added, $col) unless exists $columns->{$col};
180     $columns->{$col} = $column_info;
181   }
182   push @{ $self->_ordered_columns }, @added;
183   return $self;
184 }
185
186 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
187
188 =head2 has_column
189
190 =over
191
192 =item Arguments: $colname
193
194 =item Return value: 1/0 (true/false)
195
196 =back
197
198   if ($source->has_column($colname)) { ... }
199
200 Returns true if the source has a column of this name, false otherwise.
201
202 =cut
203
204 sub has_column {
205   my ($self, $column) = @_;
206   return exists $self->_columns->{$column};
207 }
208
209 =head2 column_info
210
211 =over
212
213 =item Arguments: $colname
214
215 =item Return value: Hashref of info
216
217 =back
218
219   my $info = $source->column_info($col);
220
221 Returns the column metadata hashref for a column, as originally passed
222 to L</add_columns>. See the description of L</add_columns> for information
223 on the contents of the hashref.
224
225 =cut
226
227 sub column_info {
228   my ($self, $column) = @_;
229   $self->throw_exception("No such column $column")
230     unless exists $self->_columns->{$column};
231   #warn $self->{_columns_info_loaded}, "\n";
232   if ( ! $self->_columns->{$column}{data_type}
233        and $self->column_info_from_storage
234        and ! $self->{_columns_info_loaded}
235        and $self->schema and $self->storage )
236   {
237     $self->{_columns_info_loaded}++;
238     my $info = {};
239     my $lc_info = {};
240     # eval for the case of storage without table
241     eval { $info = $self->storage->columns_info_for( $self->from ) };
242     unless ($@) {
243       for my $realcol ( keys %{$info} ) {
244         $lc_info->{lc $realcol} = $info->{$realcol};
245       }
246       foreach my $col ( keys %{$self->_columns} ) {
247         $self->_columns->{$col} = {
248           %{ $self->_columns->{$col} },
249           %{ $info->{$col} || $lc_info->{lc $col} || {} }
250         };
251       }
252     }
253   }
254   return $self->_columns->{$column};
255 }
256
257 =head2 columns
258
259 =over
260
261 =item Arguments: None
262
263 =item Return value: Ordered list of column names
264
265 =back
266
267   my @column_names = $source->columns;
268
269 Returns all column names in the order they were declared to L</add_columns>.
270
271 =cut
272
273 sub columns {
274   my $self = shift;
275   $self->throw_exception(
276     "columns() is a read-only accessor, did you mean add_columns()?"
277   ) if (@_ > 1);
278   return @{$self->{_ordered_columns}||[]};
279 }
280
281 =head2 remove_columns
282
283 =over
284
285 =item Arguments: @colnames
286
287 =item Return value: undefined
288
289 =back
290
291   $source->remove_columns(qw/col1 col2 col3/);
292
293 Removes the given list of columns by name, from the result source.
294
295 B<Warning>: Removing a column that is also used in the sources primary
296 key, or in one of the sources unique constraints, B<will> result in a
297 broken result source.
298
299 =head2 remove_column
300
301 =over
302
303 =item Arguments: $colname
304
305 =item Return value: undefined
306
307 =back
308
309   $source->remove_column('col');
310
311 Remove a single column by name from the result source, similar to
312 L</remove_columns>.
313
314 B<Warning>: Removing a column that is also used in the sources primary
315 key, or in one of the sources unique constraints, B<will> result in a
316 broken result source.
317
318 =cut
319
320 sub remove_columns {
321   my ($self, @cols) = @_;
322
323   return unless $self->_ordered_columns;
324
325   my $columns = $self->_columns;
326   my @remaining;
327
328   foreach my $col (@{$self->_ordered_columns}) {
329     push @remaining, $col unless grep(/$col/, @cols);
330   }
331
332   foreach (@cols) {
333     delete $columns->{$_};
334   };
335
336   $self->_ordered_columns(\@remaining);
337 }
338
339 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
340
341 =head2 set_primary_key
342
343 =over 4
344
345 =item Arguments: @cols
346
347 =item Return value: undefined
348
349 =back
350
351 Defines one or more columns as primary key for this source. Should be
352 called after L</add_columns>.
353
354 Additionally, defines a L<unique constraint|add_unique_constraint>
355 named C<primary>.
356
357 The primary key columns are used by L<DBIx::Class::PK::Auto> to
358 retrieve automatically created values from the database.
359
360 =cut
361
362 sub set_primary_key {
363   my ($self, @cols) = @_;
364   # check if primary key columns are valid columns
365   foreach my $col (@cols) {
366     $self->throw_exception("No such column $col on table " . $self->name)
367       unless $self->has_column($col);
368   }
369   $self->_primaries(\@cols);
370
371   $self->add_unique_constraint(primary => \@cols);
372 }
373
374 =head2 primary_columns
375
376 =over 4
377
378 =item Arguments: None
379
380 =item Return value: Ordered list of primary column names
381
382 =back
383
384 Read-only accessor which returns the list of primary keys, supplied by
385 L</set_primary_key>.
386
387 =cut
388
389 sub primary_columns {
390   return @{shift->_primaries||[]};
391 }
392
393 =head2 add_unique_constraint
394
395 =over 4
396
397 =item Arguments: [ $name ], \@colnames
398
399 =item Return value: undefined
400
401 =back
402
403 Declare a unique constraint on this source. Call once for each unique
404 constraint.
405
406   # For UNIQUE (column1, column2)
407   __PACKAGE__->add_unique_constraint(
408     constraint_name => [ qw/column1 column2/ ],
409   );
410
411 Alternatively, you can specify only the columns:
412
413   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
414
415 This will result in a unique constraint named C<table_column1_column2>, where
416 C<table> is replaced with the table name.
417
418 Unique constraints are used, for example, when you call
419 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
420
421 Throws an error if any of the given column names do not yet exist on
422 the result source.
423
424 =cut
425
426 sub add_unique_constraint {
427   my $self = shift;
428   my $cols = pop @_;
429   my $name = shift;
430
431   $name ||= $self->name_unique_constraint($cols);
432
433   foreach my $col (@$cols) {
434     $self->throw_exception("No such column $col on table " . $self->name)
435       unless $self->has_column($col);
436   }
437
438   my %unique_constraints = $self->unique_constraints;
439   $unique_constraints{$name} = $cols;
440   $self->_unique_constraints(\%unique_constraints);
441 }
442
443 =head2 name_unique_constraint
444
445 =over 4
446
447 =item Arguments: @colnames
448
449 =item Return value: Constraint name
450
451 =back
452
453   $source->table('mytable');
454   $source->name_unique_constraint('col1', 'col2');
455   # returns
456   'mytable_col1_col2'
457
458 Return a name for a unique constraint containing the specified
459 columns. The name is created by joining the table name and each column
460 name, using an underscore character.
461
462 For example, a constraint on a table named C<cd> containing the columns
463 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
464
465 This is used by L</add_unique_constraint> if you do not specify the
466 optional constraint name.
467
468 =cut
469
470 sub name_unique_constraint {
471   my ($self, $cols) = @_;
472
473   return join '_', $self->name, @$cols;
474 }
475
476 =head2 unique_constraints
477
478 =over 4
479
480 =item Arguments: None
481
482 =item Return value: Hash of unique constraint data
483
484 =back
485
486   $source->unique_constraints();
487
488 Read-only accessor which returns a hash of unique constraints on this source.
489
490 The hash is keyed by constraint name, and contains an arrayref of
491 column names as values.
492
493 =cut
494
495 sub unique_constraints {
496   return %{shift->_unique_constraints||{}};
497 }
498
499 =head2 unique_constraint_names
500
501 =over 4
502
503 =item Arguments: None
504
505 =item Return value: Unique constraint names
506
507 =back
508
509   $source->unique_constraint_names();
510
511 Returns the list of unique constraint names defined on this source.
512
513 =cut
514
515 sub unique_constraint_names {
516   my ($self) = @_;
517
518   my %unique_constraints = $self->unique_constraints;
519
520   return keys %unique_constraints;
521 }
522
523 =head2 unique_constraint_columns
524
525 =over 4
526
527 =item Arguments: $constraintname
528
529 =item Return value: List of constraint columns
530
531 =back
532
533   $source->unique_constraint_columns('myconstraint');
534
535 Returns the list of columns that make up the specified unique constraint.
536
537 =cut
538
539 sub unique_constraint_columns {
540   my ($self, $constraint_name) = @_;
541
542   my %unique_constraints = $self->unique_constraints;
543
544   $self->throw_exception(
545     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
546   ) unless exists $unique_constraints{$constraint_name};
547
548   return @{ $unique_constraints{$constraint_name} };
549 }
550
551 =head2 resultset
552
553 =over 4
554
555 =item Arguments: None
556
557 =item Return value: $resultset
558
559 =back
560
561 Returns a resultset for the given source. This will initially be created
562 on demand by calling
563
564   $self->resultset_class->new($self, $self->resultset_attributes)
565
566 but is cached from then on unless resultset_class changes.
567
568 =head2 resultset_class
569
570 =over 4
571
572 =item Arguments: $classname
573
574 =item Return value: $classname
575
576 =back
577
578   package My::ResultSetClass;
579   use base 'DBIx::Class::ResultSet';
580   ...
581
582   $source->resultset_class('My::ResultSet::Class');
583
584 Set the class of the resultset, this is useful if you want to create your
585 own resultset methods. Create your own class derived from
586 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
587 this method returns the name of the existing resultset class, if one
588 exists.
589
590 =head2 resultset_attributes
591
592 =over 4
593
594 =item Arguments: \%attrs
595
596 =item Return value: \%attrs
597
598 =back
599
600   $source->resultset_attributes({ order_by => [ 'id' ] });
601
602 Store a collection of resultset attributes, that will be set on every
603 L<DBIx::Class::ResultSet> produced from this result source. For a full
604 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
605
606 =cut
607
608 sub resultset {
609   my $self = shift;
610   $self->throw_exception(
611     'resultset does not take any arguments. If you want another resultset, '.
612     'call it on the schema instead.'
613   ) if scalar @_;
614
615   return $self->resultset_class->new(
616     $self,
617     {
618       %{$self->{resultset_attributes}},
619       %{$self->schema->default_resultset_attributes}
620     },
621   );
622 }
623
624 =head2 source_name
625
626 =over 4
627
628 =item Arguments: $source_name
629
630 =item Result value: $source_name
631
632 =back
633
634 Set an alternate name for the result source when it is loaded into a schema.
635 This is useful if you want to refer to a result source by a name other than
636 its class name.
637
638   package ArchivedBooks;
639   use base qw/DBIx::Class/;
640   __PACKAGE__->table('books_archive');
641   __PACKAGE__->source_name('Books');
642
643   # from your schema...
644   $schema->resultset('Books')->find(1);
645
646 =head2 from
647
648 =over 4
649
650 =item Arguments: None
651
652 =item Return value: FROM clause
653
654 =back
655
656   my $from_clause = $source->from();
657
658 Returns an expression of the source to be supplied to storage to specify
659 retrieval from this source. In the case of a database, the required FROM
660 clause contents.
661
662 =head2 schema
663
664 =over 4
665
666 =item Arguments: None
667
668 =item Return value: A schema object
669
670 =back
671
672   my $schema = $source->schema();
673
674 Returns the L<DBIx::Class::Schema> object that this result source 
675 belongs to.
676
677 =head2 storage
678
679 =over 4
680
681 =item Arguments: None
682
683 =item Return value: A Storage object
684
685 =back
686
687   $source->storage->debug(1);
688
689 Returns the storage handle for the current schema.
690
691 See also: L<DBIx::Class::Storage>
692
693 =cut
694
695 sub storage { shift->schema->storage; }
696
697 =head2 add_relationship
698
699 =over 4
700
701 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
702
703 =item Return value: 1/true if it succeeded
704
705 =back
706
707   $source->add_relationship('relname', 'related_source', $cond, $attrs);
708
709 L<DBIx::Class::Relationship> describes a series of methods which
710 create pre-defined useful types of relationships. Look there first
711 before using this method directly.
712
713 The relationship name can be arbitrary, but must be unique for each
714 relationship attached to this result source. 'related_source' should
715 be the name with which the related result source was registered with
716 the current schema. For example:
717
718   $schema->source('Book')->add_relationship('reviews', 'Review', {
719     'foreign.book_id' => 'self.id',
720   });
721
722 The condition C<$cond> needs to be an L<SQL::Abstract>-style
723 representation of the join between the tables. For example, if you're
724 creating a relation from Author to Book,
725
726   { 'foreign.author_id' => 'self.id' }
727
728 will result in the JOIN clause
729
730   author me JOIN book foreign ON foreign.author_id = me.id
731
732 You can specify as many foreign => self mappings as necessary.
733
734 Valid attributes are as follows:
735
736 =over 4
737
738 =item join_type
739
740 Explicitly specifies the type of join to use in the relationship. Any
741 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
742 the SQL command immediately before C<JOIN>.
743
744 =item proxy
745
746 An arrayref containing a list of accessors in the foreign class to proxy in
747 the main class. If, for example, you do the following:
748
749   CD->might_have(liner_notes => 'LinerNotes', undef, {
750     proxy => [ qw/notes/ ],
751   });
752
753 Then, assuming LinerNotes has an accessor named notes, you can do:
754
755   my $cd = CD->find(1);
756   # set notes -- LinerNotes object is created if it doesn't exist
757   $cd->notes('Notes go here');
758
759 =item accessor
760
761 Specifies the type of accessor that should be created for the
762 relationship. Valid values are C<single> (for when there is only a single
763 related object), C<multi> (when there can be many), and C<filter> (for
764 when there is a single related object, but you also want the relationship
765 accessor to double as a column accessor). For C<multi> accessors, an
766 add_to_* method is also created, which calls C<create_related> for the
767 relationship.
768
769 =back
770
771 Throws an exception if the condition is improperly supplied, or cannot
772 be resolved using L</resolve_join>.
773
774 =cut
775
776 sub add_relationship {
777   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
778   $self->throw_exception("Can't create relationship without join condition")
779     unless $cond;
780   $attrs ||= {};
781
782   # Check foreign and self are right in cond
783   if ( (ref $cond ||'') eq 'HASH') {
784     for (keys %$cond) {
785       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
786         if /\./ && !/^foreign\./;
787     }
788   }
789
790   my %rels = %{ $self->_relationships };
791   $rels{$rel} = { class => $f_source_name,
792                   source => $f_source_name,
793                   cond  => $cond,
794                   attrs => $attrs };
795   $self->_relationships(\%rels);
796
797   return $self;
798
799   # XXX disabled. doesn't work properly currently. skip in tests.
800
801   my $f_source = $self->schema->source($f_source_name);
802   unless ($f_source) {
803     $self->ensure_class_loaded($f_source_name);
804     $f_source = $f_source_name->result_source;
805     #my $s_class = ref($self->schema);
806     #$f_source_name =~ m/^${s_class}::(.*)$/;
807     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
808     #$f_source = $self->schema->source($f_source_name);
809   }
810   return unless $f_source; # Can't test rel without f_source
811
812   eval { $self->resolve_join($rel, 'me') };
813
814   if ($@) { # If the resolve failed, back out and re-throw the error
815     delete $rels{$rel}; #
816     $self->_relationships(\%rels);
817     $self->throw_exception("Error creating relationship $rel: $@");
818   }
819   1;
820 }
821
822 =head2 relationships
823
824 =over 4
825
826 =item Arguments: None
827
828 =item Return value: List of relationship names
829
830 =back
831
832   my @relnames = $source->relationships();
833
834 Returns all relationship names for this source.
835
836 =cut
837
838 sub relationships {
839   return keys %{shift->_relationships};
840 }
841
842 =head2 relationship_info
843
844 =over 4
845
846 =item Arguments: $relname
847
848 =item Return value: Hashref of relation data,
849
850 =back
851
852 Returns a hash of relationship information for the specified relationship
853 name. The keys/values are as specified for L</add_relationship>.
854
855 =cut
856
857 sub relationship_info {
858   my ($self, $rel) = @_;
859   return $self->_relationships->{$rel};
860 }
861
862 =head2 has_relationship
863
864 =over 4
865
866 =item Arguments: $rel
867
868 =item Return value: 1/0 (true/false)
869
870 =back
871
872 Returns true if the source has a relationship of this name, false otherwise.
873
874 =cut
875
876 sub has_relationship {
877   my ($self, $rel) = @_;
878   return exists $self->_relationships->{$rel};
879 }
880
881 =head2 reverse_relationship_info
882
883 =over 4
884
885 =item Arguments: $relname
886
887 =item Return value: Hashref of relationship data
888
889 =back
890
891 Looks through all the relationships on the source this relationship
892 points to, looking for one whose condition is the reverse of the
893 condition on this relationship.
894
895 A common use of this is to find the name of the C<belongs_to> relation
896 opposing a C<has_many> relation. For definition of these look in
897 L<DBIx::Class::Relationship>.
898
899 The returned hashref is keyed by the name of the opposing
900 relationship, and contains it's data in the same manner as
901 L</relationship_info>.
902
903 =cut
904
905 sub reverse_relationship_info {
906   my ($self, $rel) = @_;
907   my $rel_info = $self->relationship_info($rel);
908   my $ret = {};
909
910   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
911
912   my @cond = keys(%{$rel_info->{cond}});
913   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
914   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
915
916   # Get the related result source for this relationship
917   my $othertable = $self->related_source($rel);
918
919   # Get all the relationships for that source that related to this source
920   # whose foreign column set are our self columns on $rel and whose self
921   # columns are our foreign columns on $rel.
922   my @otherrels = $othertable->relationships();
923   my $otherrelationship;
924   foreach my $otherrel (@otherrels) {
925     my $otherrel_info = $othertable->relationship_info($otherrel);
926
927     my $back = $othertable->related_source($otherrel);
928     next unless $back->source_name eq $self->source_name;
929
930     my @othertestconds;
931
932     if (ref $otherrel_info->{cond} eq 'HASH') {
933       @othertestconds = ($otherrel_info->{cond});
934     }
935     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
936       @othertestconds = @{$otherrel_info->{cond}};
937     }
938     else {
939       next;
940     }
941
942     foreach my $othercond (@othertestconds) {
943       my @other_cond = keys(%$othercond);
944       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
945       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
946       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
947                !$self->compare_relationship_keys(\@other_refkeys, \@keys));
948       $ret->{$otherrel} =  $otherrel_info;
949     }
950   }
951   return $ret;
952 }
953
954 =head2 compare_relationship_keys
955
956 =over 4
957
958 =item Arguments: \@keys1, \@keys2
959
960 =item Return value: 1/0 (true/false)
961
962 =back
963
964 Returns true if both sets of keynames are the same, false otherwise.
965
966 =cut
967
968 sub compare_relationship_keys {
969   my ($self, $keys1, $keys2) = @_;
970
971   # Make sure every keys1 is in keys2
972   my $found;
973   foreach my $key (@$keys1) {
974     $found = 0;
975     foreach my $prim (@$keys2) {
976       if ($prim eq $key) {
977         $found = 1;
978         last;
979       }
980     }
981     last unless $found;
982   }
983
984   # Make sure every key2 is in key1
985   if ($found) {
986     foreach my $prim (@$keys2) {
987       $found = 0;
988       foreach my $key (@$keys1) {
989         if ($prim eq $key) {
990           $found = 1;
991           last;
992         }
993       }
994       last unless $found;
995     }
996   }
997
998   return $found;
999 }
1000
1001 =head2 sqlt_deploy_hook
1002
1003 =over 4
1004
1005 =item Arguments: $source, $sqlt_table
1006
1007 =item Return value: undefined
1008
1009 =back
1010
1011 This is NOT a method of C<ResultSource>.
1012
1013 An optional sub which you can declare in your own Result class that will get 
1014 passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1015 via L</create_ddl_dir> or L</deploy>.
1016
1017 This is useful to make L<SQL::Translator> create non-unique indexes,
1018 or set table options such as C<Engine=INNOFB>.
1019
1020 For an example of what you can do with this, see 
1021 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1022
1023 =head2 resolve_join
1024
1025 =over 4
1026
1027 =item Arguments: $relation
1028
1029 =item Return value: Join condition arrayref
1030
1031 =back
1032
1033 Returns the join structure required for the related result source.
1034
1035 =cut
1036
1037 sub resolve_join {
1038   my ($self, $join, $alias, $seen, $force_left) = @_;
1039   $seen ||= {};
1040   $force_left ||= { force => 0 };
1041   if (ref $join eq 'ARRAY') {
1042     return map { $self->resolve_join($_, $alias, $seen) } @$join;
1043   } elsif (ref $join eq 'HASH') {
1044     return
1045       map {
1046         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
1047         local $force_left->{force};
1048         (
1049           $self->resolve_join($_, $alias, $seen, $force_left),
1050           $self->related_source($_)->resolve_join(
1051             $join->{$_}, $as, $seen, $force_left
1052           )
1053         );
1054       } keys %$join;
1055   } elsif (ref $join) {
1056     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1057   } else {
1058     my $count = ++$seen->{$join};
1059     #use Data::Dumper; warn Dumper($seen);
1060     my $as = ($count > 1 ? "${join}_${count}" : $join);
1061     my $rel_info = $self->relationship_info($join);
1062     $self->throw_exception("No such relationship ${join}") unless $rel_info;
1063     my $type;
1064     if ($force_left->{force}) {
1065       $type = 'left';
1066     } else {
1067       $type = $rel_info->{attrs}{join_type} || '';
1068       $force_left->{force} = 1 if lc($type) eq 'left';
1069     }
1070     return [ { $as => $self->related_source($join)->from,
1071                -join_type => $type },
1072              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
1073   }
1074 }
1075
1076 =head2 pk_depends_on
1077
1078 =over 4
1079
1080 =item Arguments: $relname, $rel_data
1081
1082 =item Return value: 1/0 (true/false)
1083
1084 =back
1085
1086 Determines whether a relation is dependent on an object from this source
1087 having already been inserted. Takes the name of the relationship and a
1088 hashref of columns of the related object.
1089
1090 =cut
1091
1092 sub pk_depends_on {
1093   my ($self, $relname, $rel_data) = @_;
1094   my $cond = $self->relationship_info($relname)->{cond};
1095
1096   return 0 unless ref($cond) eq 'HASH';
1097
1098   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1099
1100   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1101
1102   # assume anything that references our PK probably is dependent on us
1103   # rather than vice versa, unless the far side is (a) defined or (b)
1104   # auto-increment
1105
1106   my $rel_source = $self->related_source($relname);
1107
1108   foreach my $p ($self->primary_columns) {
1109     if (exists $keyhash->{$p}) {
1110       unless (defined($rel_data->{$keyhash->{$p}})
1111               || $rel_source->column_info($keyhash->{$p})
1112                             ->{is_auto_increment}) {
1113         return 0;
1114       }
1115     }
1116   }
1117
1118   return 1;
1119 }
1120
1121 =head2 resolve_condition
1122
1123 =over 4
1124
1125 =item Arguments: $cond, $as, $alias|$object
1126
1127 =back
1128
1129 Resolves the passed condition to a concrete query fragment. If given an alias,
1130 returns a join condition; if given an object, inverts that object to produce
1131 a related conditional from that object.
1132
1133 =cut
1134
1135 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1136
1137 sub resolve_condition {
1138   my ($self, $cond, $as, $for) = @_;
1139   #warn %$cond;
1140   if (ref $cond eq 'HASH') {
1141     my %ret;
1142     foreach my $k (keys %{$cond}) {
1143       my $v = $cond->{$k};
1144       # XXX should probably check these are valid columns
1145       $k =~ s/^foreign\.// ||
1146         $self->throw_exception("Invalid rel cond key ${k}");
1147       $v =~ s/^self\.// ||
1148         $self->throw_exception("Invalid rel cond val ${v}");
1149       if (ref $for) { # Object
1150         #warn "$self $k $for $v";
1151         unless ($for->has_column_loaded($v)) {
1152           if ($for->in_storage) {
1153             $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
1154           }
1155           return $UNRESOLVABLE_CONDITION;
1156         }
1157         $ret{$k} = $for->get_column($v);
1158         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1159         #warn %ret;
1160       } elsif (!defined $for) { # undef, i.e. "no object"
1161         $ret{$k} = undef;
1162       } elsif (ref $as eq 'HASH') { # reverse hashref
1163         $ret{$v} = $as->{$k};
1164       } elsif (ref $as) { # reverse object
1165         $ret{$v} = $as->get_column($k);
1166       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1167         $ret{$v} = undef;
1168       } else {
1169         $ret{"${as}.${k}"} = "${for}.${v}";
1170       }
1171     }
1172     return \%ret;
1173   } elsif (ref $cond eq 'ARRAY') {
1174     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1175   } else {
1176    die("Can't handle this yet :(");
1177   }
1178 }
1179
1180 =head2 resolve_prefetch
1181
1182 =over 4
1183
1184 =item Arguments: hashref/arrayref/scalar
1185
1186 =back
1187
1188 Accepts one or more relationships for the current source and returns an
1189 array of column names for each of those relationships. Column names are
1190 prefixed relative to the current source, in accordance with where they appear
1191 in the supplied relationships. Examples:
1192
1193   my $source = $schema->resultset('Tag')->source;
1194   @columns = $source->resolve_prefetch( { cd => 'artist' } );
1195
1196   # @columns =
1197   #(
1198   #  'cd.cdid',
1199   #  'cd.artist',
1200   #  'cd.title',
1201   #  'cd.year',
1202   #  'cd.artist.artistid',
1203   #  'cd.artist.name'
1204   #)
1205
1206   @columns = $source->resolve_prefetch( qw[/ cd /] );
1207
1208   # @columns =
1209   #(
1210   #   'cd.cdid',
1211   #   'cd.artist',
1212   #   'cd.title',
1213   #   'cd.year'
1214   #)
1215
1216   $source = $schema->resultset('CD')->source;
1217   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1218
1219   # @columns =
1220   #(
1221   #  'artist.artistid',
1222   #  'artist.name',
1223   #  'producer.producerid',
1224   #  'producer.name'
1225   #)
1226
1227 =cut
1228
1229 sub resolve_prefetch {
1230   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1231   $seen ||= {};
1232   #$alias ||= $self->name;
1233   #warn $alias, Dumper $pre;
1234   if( ref $pre eq 'ARRAY' ) {
1235     return
1236       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1237         @$pre;
1238   }
1239   elsif( ref $pre eq 'HASH' ) {
1240     my @ret =
1241     map {
1242       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1243       $self->related_source($_)->resolve_prefetch(
1244                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1245     } keys %$pre;
1246     #die Dumper \@ret;
1247     return @ret;
1248   }
1249   elsif( ref $pre ) {
1250     $self->throw_exception(
1251       "don't know how to resolve prefetch reftype ".ref($pre));
1252   }
1253   else {
1254     my $count = ++$seen->{$pre};
1255     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1256     my $rel_info = $self->relationship_info( $pre );
1257     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1258       unless $rel_info;
1259     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1260     my $rel_source = $self->related_source($pre);
1261
1262     if (exists $rel_info->{attrs}{accessor}
1263          && $rel_info->{attrs}{accessor} eq 'multi') {
1264       $self->throw_exception(
1265         "Can't prefetch has_many ${pre} (join cond too complex)")
1266         unless ref($rel_info->{cond}) eq 'HASH';
1267       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1268       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1269                          keys %{$collapse}) {
1270         my ($last) = ($fail =~ /([^\.]+)$/);
1271         carp (
1272           "Prefetching multiple has_many rels ${last} and ${pre} "
1273           .(length($as_prefix)
1274             ? "at the same level (${as_prefix}) "
1275             : "at top level "
1276           )
1277           . 'will currently disrupt both the functionality of $rs->count(), '
1278           . 'and the amount of objects retrievable via $rs->next(). '
1279           . 'Use at your own risk.'
1280         );
1281       }
1282       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1283       #              values %{$rel_info->{cond}};
1284       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1285         # action at a distance. prepending the '.' allows simpler code
1286         # in ResultSet->_collapse_result
1287       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1288                     keys %{$rel_info->{cond}};
1289       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1290                    ? @{$rel_info->{attrs}{order_by}}
1291                    : (defined $rel_info->{attrs}{order_by}
1292                        ? ($rel_info->{attrs}{order_by})
1293                        : ()));
1294       push(@$order, map { "${as}.$_" } (@key, @ord));
1295     }
1296
1297     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1298       $rel_source->columns;
1299     #warn $alias, Dumper (\@ret);
1300     #return @ret;
1301   }
1302 }
1303
1304 =head2 related_source
1305
1306 =over 4
1307
1308 =item Arguments: $relname
1309
1310 =item Return value: $source
1311
1312 =back
1313
1314 Returns the result source object for the given relationship.
1315
1316 =cut
1317
1318 sub related_source {
1319   my ($self, $rel) = @_;
1320   if( !$self->has_relationship( $rel ) ) {
1321     $self->throw_exception("No such relationship '$rel'");
1322   }
1323   return $self->schema->source($self->relationship_info($rel)->{source});
1324 }
1325
1326 =head2 related_class
1327
1328 =over 4
1329
1330 =item Arguments: $relname
1331
1332 =item Return value: $classname
1333
1334 =back
1335
1336 Returns the class name for objects in the given relationship.
1337
1338 =cut
1339
1340 sub related_class {
1341   my ($self, $rel) = @_;
1342   if( !$self->has_relationship( $rel ) ) {
1343     $self->throw_exception("No such relationship '$rel'");
1344   }
1345   return $self->schema->class($self->relationship_info($rel)->{source});
1346 }
1347
1348 =head2 handle
1349
1350 Obtain a new handle to this source. Returns an instance of a 
1351 L<DBIx::Class::ResultSourceHandle>.
1352
1353 =cut
1354
1355 sub handle {
1356     return new DBIx::Class::ResultSourceHandle({
1357         schema         => $_[0]->schema,
1358         source_moniker => $_[0]->source_name
1359     });
1360 }
1361
1362 =head2 throw_exception
1363
1364 See L<DBIx::Class::Schema/"throw_exception">.
1365
1366 =cut
1367
1368 sub throw_exception {
1369   my $self = shift;
1370   if (defined $self->schema) {
1371     $self->schema->throw_exception(@_);
1372   } else {
1373     croak(@_);
1374   }
1375 }
1376
1377 =head2 source_info
1378
1379 Stores a hashref of per-source metadata.  No specific key names
1380 have yet been standardized, the examples below are purely hypothetical
1381 and don't actually accomplish anything on their own:
1382
1383   __PACKAGE__->source_info({
1384     "_tablespace" => 'fast_disk_array_3',
1385     "_engine" => 'InnoDB',
1386   });
1387
1388 =head2 new
1389
1390   $class->new();
1391
1392   $class->new({attribute_name => value});
1393
1394 Creates a new ResultSource object.  Not normally called directly by end users.
1395
1396 =cut
1397
1398 =head2 column_info_from_storage
1399
1400 =over
1401
1402 =item Arguments: 1/0 (default: 0)
1403
1404 =item Return value: 1/0
1405
1406 =back
1407
1408 Enables the on-demand automatic loading of the above column
1409 metadata from storage as neccesary.  This is *deprecated*, and
1410 should not be used.  It will be removed before 1.0.
1411
1412   __PACKAGE__->column_info_from_storage(1);
1413
1414 =cut
1415
1416 =head2 sqlt_deploy_hook($sqlt_table)
1417
1418 Triggers C<sqlt_deploy_callback>.
1419
1420 =cut
1421
1422 sub sqlt_deploy_hook {
1423   my $self = shift;
1424   if ( my $hook = $self->sqlt_deploy_callback) {
1425     $self->$hook(@_);
1426   }
1427 }
1428
1429 =head2 default_sqlt_deploy_hook($table)
1430
1431 Delegates to a an optional C<sqlt_deploy_hook> method on the C<result_class>.
1432
1433 This will get passed the L<SQL::Translator::Schema::Table> object when you
1434 deploy the schema via L</create_ddl_dir> or L</deploy>.
1435
1436 For an example of what you can do with this, see 
1437 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1438
1439 =cut
1440
1441 sub default_sqlt_deploy_hook {
1442   my $self = shift;
1443
1444   my $class = $self->result_class;
1445
1446   if ($class and $class->can('sqlt_deploy_hook')) {
1447     $class->sqlt_deploy_hook(@_);
1448   }
1449 }
1450
1451 =head2 sqlt_deploy_callback
1452
1453 An attribute which contains the callback to trigger on C<sqlt_deploy_hook>.
1454 Defaults to C<default_sqlt_deploy_hook>. Can be a code reference or a method
1455 name.
1456
1457 =head1 AUTHORS
1458
1459 Matt S. Trout <mst@shadowcatsystems.co.uk>
1460
1461 =head1 LICENSE
1462
1463 You may distribute this code under the same terms as Perl itself.
1464
1465 =cut
1466
1467 1;