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