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