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