skip test doc issue relating to db-side defaults
[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 C<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 using L</resolve_join>.
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 =head2 compare_relationship_keys
1027
1028 =over 4
1029
1030 =item Arguments: \@keys1, \@keys2
1031
1032 =item Return value: 1/0 (true/false)
1033
1034 =back
1035
1036 Returns true if both sets of keynames are the same, false otherwise.
1037
1038 =cut
1039
1040 sub compare_relationship_keys {
1041   my ($self, $keys1, $keys2) = @_;
1042
1043   # Make sure every keys1 is in keys2
1044   my $found;
1045   foreach my $key (@$keys1) {
1046     $found = 0;
1047     foreach my $prim (@$keys2) {
1048       if ($prim eq $key) {
1049         $found = 1;
1050         last;
1051       }
1052     }
1053     last unless $found;
1054   }
1055
1056   # Make sure every key2 is in key1
1057   if ($found) {
1058     foreach my $prim (@$keys2) {
1059       $found = 0;
1060       foreach my $key (@$keys1) {
1061         if ($prim eq $key) {
1062           $found = 1;
1063           last;
1064         }
1065       }
1066       last unless $found;
1067     }
1068   }
1069
1070   return $found;
1071 }
1072
1073 =head2 resolve_join
1074
1075 =over 4
1076
1077 =item Arguments: $relation
1078
1079 =item Return value: Join condition arrayref
1080
1081 =back
1082
1083 Returns the join structure required for the related result source.
1084
1085 =cut
1086
1087 sub resolve_join {
1088   my ($self, $join, $alias, $seen, $force_left) = @_;
1089   $seen ||= {};
1090   $force_left ||= { force => 0 };
1091   if (ref $join eq 'ARRAY') {
1092     return map { $self->resolve_join($_, $alias, $seen) } @$join;
1093   } elsif (ref $join eq 'HASH') {
1094     return
1095       map {
1096         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
1097         local $force_left->{force};
1098         (
1099           $self->resolve_join($_, $alias, $seen, $force_left),
1100           $self->related_source($_)->resolve_join(
1101             $join->{$_}, $as, $seen, $force_left
1102           )
1103         );
1104       } keys %$join;
1105   } elsif (ref $join) {
1106     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1107   } else {
1108     my $count = ++$seen->{$join};
1109     #use Data::Dumper; warn Dumper($seen);
1110     my $as = ($count > 1 ? "${join}_${count}" : $join);
1111     my $rel_info = $self->relationship_info($join);
1112     $self->throw_exception("No such relationship ${join}") unless $rel_info;
1113     my $type;
1114     if ($force_left->{force}) {
1115       $type = 'left';
1116     } else {
1117       $type = $rel_info->{attrs}{join_type} || '';
1118       $force_left->{force} = 1 if lc($type) eq 'left';
1119     }
1120     return [ { $as => $self->related_source($join)->from,
1121                -join_type => $type },
1122              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
1123   }
1124 }
1125
1126 =head2 pk_depends_on
1127
1128 =over 4
1129
1130 =item Arguments: $relname, $rel_data
1131
1132 =item Return value: 1/0 (true/false)
1133
1134 =back
1135
1136 Determines whether a relation is dependent on an object from this source
1137 having already been inserted. Takes the name of the relationship and a
1138 hashref of columns of the related object.
1139
1140 =cut
1141
1142 sub pk_depends_on {
1143   my ($self, $relname, $rel_data) = @_;
1144   my $cond = $self->relationship_info($relname)->{cond};
1145
1146   return 0 unless ref($cond) eq 'HASH';
1147
1148   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1149
1150   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1151
1152   # assume anything that references our PK probably is dependent on us
1153   # rather than vice versa, unless the far side is (a) defined or (b)
1154   # auto-increment
1155
1156   my $rel_source = $self->related_source($relname);
1157
1158   foreach my $p ($self->primary_columns) {
1159     if (exists $keyhash->{$p}) {
1160       unless (defined($rel_data->{$keyhash->{$p}})
1161               || $rel_source->column_info($keyhash->{$p})
1162                             ->{is_auto_increment}) {
1163         return 0;
1164       }
1165     }
1166   }
1167
1168   return 1;
1169 }
1170
1171 =head2 resolve_condition
1172
1173 =over 4
1174
1175 =item Arguments: $cond, $as, $alias|$object
1176
1177 =back
1178
1179 Resolves the passed condition to a concrete query fragment. If given an alias,
1180 returns a join condition; if given an object, inverts that object to produce
1181 a related conditional from that object.
1182
1183 =cut
1184
1185 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1186
1187 sub resolve_condition {
1188   my ($self, $cond, $as, $for) = @_;
1189   #warn %$cond;
1190   if (ref $cond eq 'HASH') {
1191     my %ret;
1192     foreach my $k (keys %{$cond}) {
1193       my $v = $cond->{$k};
1194       # XXX should probably check these are valid columns
1195       $k =~ s/^foreign\.// ||
1196         $self->throw_exception("Invalid rel cond key ${k}");
1197       $v =~ s/^self\.// ||
1198         $self->throw_exception("Invalid rel cond val ${v}");
1199       if (ref $for) { # Object
1200         #warn "$self $k $for $v";
1201         unless ($for->has_column_loaded($v)) {
1202           if ($for->in_storage) {
1203             $self->throw_exception(
1204               "Column ${v} not loaded or not passed to new() prior to insert()"
1205                 ." on ${for} trying to resolve relationship (maybe you forgot "
1206                   ."to call ->reload_from_storage to get defaults from the db)"
1207             );
1208           }
1209           return $UNRESOLVABLE_CONDITION;
1210         }
1211         $ret{$k} = $for->get_column($v);
1212         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1213         #warn %ret;
1214       } elsif (!defined $for) { # undef, i.e. "no object"
1215         $ret{$k} = undef;
1216       } elsif (ref $as eq 'HASH') { # reverse hashref
1217         $ret{$v} = $as->{$k};
1218       } elsif (ref $as) { # reverse object
1219         $ret{$v} = $as->get_column($k);
1220       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1221         $ret{$v} = undef;
1222       } else {
1223         $ret{"${as}.${k}"} = "${for}.${v}";
1224       }
1225     }
1226     return \%ret;
1227   } elsif (ref $cond eq 'ARRAY') {
1228     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1229   } else {
1230    die("Can't handle this yet :(");
1231   }
1232 }
1233
1234 =head2 resolve_prefetch
1235
1236 =over 4
1237
1238 =item Arguments: hashref/arrayref/scalar
1239
1240 =back
1241
1242 Accepts one or more relationships for the current source and returns an
1243 array of column names for each of those relationships. Column names are
1244 prefixed relative to the current source, in accordance with where they appear
1245 in the supplied relationships. Examples:
1246
1247   my $source = $schema->resultset('Tag')->source;
1248   @columns = $source->resolve_prefetch( { cd => 'artist' } );
1249
1250   # @columns =
1251   #(
1252   #  'cd.cdid',
1253   #  'cd.artist',
1254   #  'cd.title',
1255   #  'cd.year',
1256   #  'cd.artist.artistid',
1257   #  'cd.artist.name'
1258   #)
1259
1260   @columns = $source->resolve_prefetch( qw[/ cd /] );
1261
1262   # @columns =
1263   #(
1264   #   'cd.cdid',
1265   #   'cd.artist',
1266   #   'cd.title',
1267   #   'cd.year'
1268   #)
1269
1270   $source = $schema->resultset('CD')->source;
1271   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1272
1273   # @columns =
1274   #(
1275   #  'artist.artistid',
1276   #  'artist.name',
1277   #  'producer.producerid',
1278   #  'producer.name'
1279   #)
1280
1281 =cut
1282
1283 sub resolve_prefetch {
1284   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1285   $seen ||= {};
1286   #$alias ||= $self->name;
1287   #warn $alias, Dumper $pre;
1288   if( ref $pre eq 'ARRAY' ) {
1289     return
1290       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1291         @$pre;
1292   }
1293   elsif( ref $pre eq 'HASH' ) {
1294     my @ret =
1295     map {
1296       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1297       $self->related_source($_)->resolve_prefetch(
1298                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1299     } keys %$pre;
1300     #die Dumper \@ret;
1301     return @ret;
1302   }
1303   elsif( ref $pre ) {
1304     $self->throw_exception(
1305       "don't know how to resolve prefetch reftype ".ref($pre));
1306   }
1307   else {
1308     my $count = ++$seen->{$pre};
1309     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1310     my $rel_info = $self->relationship_info( $pre );
1311     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1312       unless $rel_info;
1313     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1314     my $rel_source = $self->related_source($pre);
1315
1316     if (exists $rel_info->{attrs}{accessor}
1317          && $rel_info->{attrs}{accessor} eq 'multi') {
1318       $self->throw_exception(
1319         "Can't prefetch has_many ${pre} (join cond too complex)")
1320         unless ref($rel_info->{cond}) eq 'HASH';
1321       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1322       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1323                          keys %{$collapse}) {
1324         my ($last) = ($fail =~ /([^\.]+)$/);
1325         carp (
1326           "Prefetching multiple has_many rels ${last} and ${pre} "
1327           .(length($as_prefix)
1328             ? "at the same level (${as_prefix}) "
1329             : "at top level "
1330           )
1331           . 'will currently disrupt both the functionality of $rs->count(), '
1332           . 'and the amount of objects retrievable via $rs->next(). '
1333           . 'Use at your own risk.'
1334         );
1335       }
1336       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1337       #              values %{$rel_info->{cond}};
1338       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1339         # action at a distance. prepending the '.' allows simpler code
1340         # in ResultSet->_collapse_result
1341       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1342                     keys %{$rel_info->{cond}};
1343       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1344                    ? @{$rel_info->{attrs}{order_by}}
1345                    : (defined $rel_info->{attrs}{order_by}
1346                        ? ($rel_info->{attrs}{order_by})
1347                        : ()));
1348       push(@$order, map { "${as}.$_" } (@key, @ord));
1349     }
1350
1351     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1352       $rel_source->columns;
1353     #warn $alias, Dumper (\@ret);
1354     #return @ret;
1355   }
1356 }
1357
1358 =head2 related_source
1359
1360 =over 4
1361
1362 =item Arguments: $relname
1363
1364 =item Return value: $source
1365
1366 =back
1367
1368 Returns the result source object for the given relationship.
1369
1370 =cut
1371
1372 sub related_source {
1373   my ($self, $rel) = @_;
1374   if( !$self->has_relationship( $rel ) ) {
1375     $self->throw_exception("No such relationship '$rel'");
1376   }
1377   return $self->schema->source($self->relationship_info($rel)->{source});
1378 }
1379
1380 =head2 related_class
1381
1382 =over 4
1383
1384 =item Arguments: $relname
1385
1386 =item Return value: $classname
1387
1388 =back
1389
1390 Returns the class name for objects in the given relationship.
1391
1392 =cut
1393
1394 sub related_class {
1395   my ($self, $rel) = @_;
1396   if( !$self->has_relationship( $rel ) ) {
1397     $self->throw_exception("No such relationship '$rel'");
1398   }
1399   return $self->schema->class($self->relationship_info($rel)->{source});
1400 }
1401
1402 =head2 handle
1403
1404 Obtain a new handle to this source. Returns an instance of a 
1405 L<DBIx::Class::ResultSourceHandle>.
1406
1407 =cut
1408
1409 sub handle {
1410     return new DBIx::Class::ResultSourceHandle({
1411         schema         => $_[0]->schema,
1412         source_moniker => $_[0]->source_name
1413     });
1414 }
1415
1416 =head2 throw_exception
1417
1418 See L<DBIx::Class::Schema/"throw_exception">.
1419
1420 =cut
1421
1422 sub throw_exception {
1423   my $self = shift;
1424   if (defined $self->schema) {
1425     $self->schema->throw_exception(@_);
1426   } else {
1427     croak(@_);
1428   }
1429 }
1430
1431 =head2 source_info
1432
1433 Stores a hashref of per-source metadata.  No specific key names
1434 have yet been standardized, the examples below are purely hypothetical
1435 and don't actually accomplish anything on their own:
1436
1437   __PACKAGE__->source_info({
1438     "_tablespace" => 'fast_disk_array_3',
1439     "_engine" => 'InnoDB',
1440   });
1441
1442 =head2 new
1443
1444   $class->new();
1445
1446   $class->new({attribute_name => value});
1447
1448 Creates a new ResultSource object.  Not normally called directly by end users.
1449
1450 =head2 column_info_from_storage
1451
1452 =over
1453
1454 =item Arguments: 1/0 (default: 0)
1455
1456 =item Return value: 1/0
1457
1458 =back
1459
1460   __PACKAGE__->column_info_from_storage(1);
1461
1462 Enables the on-demand automatic loading of the above column
1463 metadata from storage as neccesary.  This is *deprecated*, and
1464 should not be used.  It will be removed before 1.0.
1465
1466
1467 =head1 AUTHORS
1468
1469 Matt S. Trout <mst@shadowcatsystems.co.uk>
1470
1471 =head1 LICENSE
1472
1473 You may distribute this code under the same terms as Perl itself.
1474
1475 =cut
1476
1477 1;