Expand/fortify the handling of attributes
[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 base 'DBIx::Class::ResultSource::RowParser';
7 use mro 'c3';
8
9 use DBIx::Class::Carp;
10 use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call );
11 use SQL::Abstract 'is_literal_value';
12 use Devel::GlobalDestruction;
13 use Scalar::Util qw/blessed weaken isweak/;
14
15 # FIXME - somehow breaks ResultSetManager, do not remove until investigated
16 use DBIx::Class::ResultSet;
17
18 use namespace::clean;
19
20 __PACKAGE__->mk_group_accessors(simple => qw/
21   source_name name source_info
22   _ordered_columns _columns _primaries _unique_constraints
23   _relationships resultset_attributes
24   column_info_from_storage sqlt_deploy_callback
25 /);
26
27 __PACKAGE__->mk_group_accessors(component_class => qw/
28   resultset_class
29   result_class
30 /);
31
32 =head1 NAME
33
34 DBIx::Class::ResultSource - Result source object
35
36 =head1 SYNOPSIS
37
38   # Create a table based result source, in a result class.
39
40   package MyApp::Schema::Result::Artist;
41   use base qw/DBIx::Class::Core/;
42
43   __PACKAGE__->table('artist');
44   __PACKAGE__->add_columns(qw/ artistid name /);
45   __PACKAGE__->set_primary_key('artistid');
46   __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD');
47
48   1;
49
50   # Create a query (view) based result source, in a result class
51   package MyApp::Schema::Result::Year2000CDs;
52   use base qw/DBIx::Class::Core/;
53
54   __PACKAGE__->load_components('InflateColumn::DateTime');
55   __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
56
57   __PACKAGE__->table('year2000cds');
58   __PACKAGE__->result_source_instance->is_virtual(1);
59   __PACKAGE__->result_source_instance->view_definition(
60       "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
61       );
62
63
64 =head1 DESCRIPTION
65
66 A ResultSource is an object that represents a source of data for querying.
67
68 This class is a base class for various specialised types of result
69 sources, for example L<DBIx::Class::ResultSource::Table>. Table is the
70 default result source type, so one is created for you when defining a
71 result class as described in the synopsis above.
72
73 More specifically, the L<DBIx::Class::Core> base class pulls in the
74 L<DBIx::Class::ResultSourceProxy::Table> component, which defines
75 the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
76 When called, C<table> creates and stores an instance of
77 L<DBIx::Class::ResultSource::Table>. Luckily, to use tables as result
78 sources, you don't need to remember any of this.
79
80 Result sources representing select queries, or views, can also be
81 created, see L<DBIx::Class::ResultSource::View> for full details.
82
83 =head2 Finding result source objects
84
85 As mentioned above, a result source instance is created and stored for
86 you when you define a
87 L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
88
89 You can retrieve the result source at runtime in the following ways:
90
91 =over
92
93 =item From a Schema object:
94
95    $schema->source($source_name);
96
97 =item From a Result object:
98
99    $result->result_source;
100
101 =item From a ResultSet object:
102
103    $rs->result_source;
104
105 =back
106
107 =head1 METHODS
108
109 =head2 new
110
111   $class->new();
112
113   $class->new({attribute_name => value});
114
115 Creates a new ResultSource object.  Not normally called directly by end users.
116
117 =cut
118
119 sub new {
120   my ($class, $attrs) = @_;
121   $class = ref $class if ref $class;
122
123   my $new = bless { %{$attrs || {}} }, $class;
124   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
125   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
126   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
127   $new->{_columns} = { %{$new->{_columns}||{}} };
128   $new->{_relationships} = { %{$new->{_relationships}||{}} };
129   $new->{name} ||= "!!NAME NOT SET!!";
130   $new->{_columns_info_loaded} ||= 0;
131   $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
132   return $new;
133 }
134
135 =pod
136
137 =head2 add_columns
138
139 =over
140
141 =item Arguments: @columns
142
143 =item Return Value: L<$result_source|/new>
144
145 =back
146
147   $source->add_columns(qw/col1 col2 col3/);
148
149   $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
150
151   $source->add_columns(
152     'col1' => { data_type => 'integer', is_nullable => 1, ... },
153     'col2' => { data_type => 'text',    is_auto_increment => 1, ... },
154   );
155
156 Adds columns to the result source. If supplied colname => hashref
157 pairs, uses the hashref as the L</column_info> for that column. Repeated
158 calls of this method will add more columns, not replace them.
159
160 The column names given will be created as accessor methods on your
161 L<Result|DBIx::Class::Manual::ResultClass> objects. You can change the name of the accessor
162 by supplying an L</accessor> in the column_info hash.
163
164 If a column name beginning with a plus sign ('+col1') is provided, the
165 attributes provided will be merged with any existing attributes for the
166 column, with the new attributes taking precedence in the case that an
167 attribute already exists. Using this without a hashref
168 (C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
169 it does the same thing it would do without the plus.
170
171 The contents of the column_info are not set in stone. The following
172 keys are currently recognised/used by DBIx::Class:
173
174 =over 4
175
176 =item accessor
177
178    { accessor => '_name' }
179
180    # example use, replace standard accessor with one of your own:
181    sub name {
182        my ($self, $value) = @_;
183
184        die "Name cannot contain digits!" if($value =~ /\d/);
185        $self->_name($value);
186
187        return $self->_name();
188    }
189
190 Use this to set the name of the accessor method for this column. If unset,
191 the name of the column will be used.
192
193 =item data_type
194
195    { data_type => 'integer' }
196
197 This contains the column type. It is automatically filled if you use the
198 L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
199 L<DBIx::Class::Schema::Loader> module.
200
201 Currently there is no standard set of values for the data_type. Use
202 whatever your database supports.
203
204 =item size
205
206    { size => 20 }
207
208 The length of your column, if it is a column type that can have a size
209 restriction. This is currently only used to create tables from your
210 schema, see L<DBIx::Class::Schema/deploy>.
211
212    { size => [ 9, 6 ] }
213
214 For decimal or float values you can specify an ArrayRef in order to
215 control precision, assuming your database's
216 L<SQL::Translator::Producer> supports it.
217
218 =item is_nullable
219
220    { is_nullable => 1 }
221
222 Set this to a true value for a column that is allowed to contain NULL
223 values, default is false. This is currently only used to create tables
224 from your schema, see L<DBIx::Class::Schema/deploy>.
225
226 =item is_auto_increment
227
228    { is_auto_increment => 1 }
229
230 Set this to a true value for a column whose value is somehow
231 automatically set, defaults to false. This is used to determine which
232 columns to empty when cloning objects using
233 L<DBIx::Class::Row/copy>. It is also used by
234 L<DBIx::Class::Schema/deploy>.
235
236 =item is_numeric
237
238    { is_numeric => 1 }
239
240 Set this to a true or false value (not C<undef>) to explicitly specify
241 if this column contains numeric data. This controls how set_column
242 decides whether to consider a column dirty after an update: if
243 C<is_numeric> is true a numeric comparison C<< != >> will take place
244 instead of the usual C<eq>
245
246 If not specified the storage class will attempt to figure this out on
247 first access to the column, based on the column C<data_type>. The
248 result will be cached in this attribute.
249
250 =item is_foreign_key
251
252    { is_foreign_key => 1 }
253
254 Set this to a true value for a column that contains a key from a
255 foreign table, defaults to false. This is currently only used to
256 create tables from your schema, see L<DBIx::Class::Schema/deploy>.
257
258 =item default_value
259
260    { default_value => \'now()' }
261
262 Set this to the default value which will be inserted into a column by
263 the database. Can contain either a value or a function (use a
264 reference to a scalar e.g. C<\'now()'> if you want a function). This
265 is currently only used to create tables from your schema, see
266 L<DBIx::Class::Schema/deploy>.
267
268 See the note on L<DBIx::Class::Row/new> for more information about possible
269 issues related to db-side default values.
270
271 =item sequence
272
273    { sequence => 'my_table_seq' }
274
275 Set this on a primary key column to the name of the sequence used to
276 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
277 will attempt to retrieve the name of the sequence from the database
278 automatically.
279
280 =item retrieve_on_insert
281
282   { retrieve_on_insert => 1 }
283
284 For every column where this is set to true, DBIC will retrieve the RDBMS-side
285 value upon a new row insertion (normally only the autoincrement PK is
286 retrieved on insert). C<INSERT ... RETURNING> is used automatically if
287 supported by the underlying storage, otherwise an extra SELECT statement is
288 executed to retrieve the missing data.
289
290 =item auto_nextval
291
292    { auto_nextval => 1 }
293
294 Set this to a true value for a column whose value is retrieved automatically
295 from a sequence or function (if supported by your Storage driver.) For a
296 sequence, if you do not use a trigger to get the nextval, you have to set the
297 L</sequence> value as well.
298
299 Also set this for MSSQL columns with the 'uniqueidentifier'
300 L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
301 automatically generate using C<NEWID()>, unless they are a primary key in which
302 case this will be done anyway.
303
304 =item extra
305
306 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
307 to add extra non-generic data to the column. For example: C<< extra
308 => { unsigned => 1} >> is used by the MySQL producer to set an integer
309 column to unsigned. For more details, see
310 L<SQL::Translator::Producer::MySQL>.
311
312 =back
313
314 =head2 add_column
315
316 =over
317
318 =item Arguments: $colname, \%columninfo?
319
320 =item Return Value: 1/0 (true/false)
321
322 =back
323
324   $source->add_column('col' => \%info);
325
326 Add a single column and optional column info. Uses the same column
327 info keys as L</add_columns>.
328
329 =cut
330
331 sub add_columns {
332   my ($self, @cols) = @_;
333   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
334
335   my @added;
336   my $columns = $self->_columns;
337   while (my $col = shift @cols) {
338     my $column_info = {};
339     if ($col =~ s/^\+//) {
340       $column_info = $self->column_info($col);
341     }
342
343     # If next entry is { ... } use that for the column info, if not
344     # use an empty hashref
345     if (ref $cols[0]) {
346       my $new_info = shift(@cols);
347       %$column_info = (%$column_info, %$new_info);
348     }
349     push(@added, $col) unless exists $columns->{$col};
350     $columns->{$col} = $column_info;
351   }
352   push @{ $self->_ordered_columns }, @added;
353   return $self;
354 }
355
356 sub add_column {
357   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
358   shift->add_columns(@_)
359 }
360
361 =head2 has_column
362
363 =over
364
365 =item Arguments: $colname
366
367 =item Return Value: 1/0 (true/false)
368
369 =back
370
371   if ($source->has_column($colname)) { ... }
372
373 Returns true if the source has a column of this name, false otherwise.
374
375 =cut
376
377 sub has_column {
378   my ($self, $column) = @_;
379   return exists $self->_columns->{$column};
380 }
381
382 =head2 column_info
383
384 =over
385
386 =item Arguments: $colname
387
388 =item Return Value: Hashref of info
389
390 =back
391
392   my $info = $source->column_info($col);
393
394 Returns the column metadata hashref for a column, as originally passed
395 to L</add_columns>. See L</add_columns> above for information on the
396 contents of the hashref.
397
398 =cut
399
400 sub column_info {
401   my ($self, $column) = @_;
402   $self->throw_exception("No such column $column")
403     unless exists $self->_columns->{$column};
404
405   if ( ! $self->_columns->{$column}{data_type}
406        and ! $self->{_columns_info_loaded}
407        and $self->column_info_from_storage
408        and my $stor = dbic_internal_try { $self->schema->storage } )
409   {
410     $self->{_columns_info_loaded}++;
411
412     # try for the case of storage without table
413     dbic_internal_try {
414       my $info = $stor->columns_info_for( $self->from );
415       my $lc_info = { map
416         { (lc $_) => $info->{$_} }
417         ( keys %$info )
418       };
419
420       foreach my $col ( keys %{$self->_columns} ) {
421         $self->_columns->{$col} = {
422           %{ $self->_columns->{$col} },
423           %{ $info->{$col} || $lc_info->{lc $col} || {} }
424         };
425       }
426     };
427   }
428
429   return $self->_columns->{$column};
430 }
431
432 =head2 columns
433
434 =over
435
436 =item Arguments: none
437
438 =item Return Value: Ordered list of column names
439
440 =back
441
442   my @column_names = $source->columns;
443
444 Returns all column names in the order they were declared to L</add_columns>.
445
446 =cut
447
448 sub columns {
449   my $self = shift;
450   $self->throw_exception(
451     "columns() is a read-only accessor, did you mean add_columns()?"
452   ) if @_;
453   return @{$self->{_ordered_columns}||[]};
454 }
455
456 =head2 columns_info
457
458 =over
459
460 =item Arguments: \@colnames ?
461
462 =item Return Value: Hashref of column name/info pairs
463
464 =back
465
466   my $columns_info = $source->columns_info;
467
468 Like L</column_info> but returns information for the requested columns. If
469 the optional column-list arrayref is omitted it returns info on all columns
470 currently defined on the ResultSource via L</add_columns>.
471
472 =cut
473
474 sub columns_info {
475   my ($self, $columns) = @_;
476
477   my $colinfo = $self->_columns;
478
479   if (
480     ! $self->{_columns_info_loaded}
481       and
482     $self->column_info_from_storage
483       and
484     grep { ! $_->{data_type} } values %$colinfo
485       and
486     my $stor = dbic_internal_try { $self->schema->storage }
487   ) {
488     $self->{_columns_info_loaded}++;
489
490     # try for the case of storage without table
491     dbic_internal_try {
492       my $info = $stor->columns_info_for( $self->from );
493       my $lc_info = { map
494         { (lc $_) => $info->{$_} }
495         ( keys %$info )
496       };
497
498       foreach my $col ( keys %$colinfo ) {
499         $colinfo->{$col} = {
500           %{ $colinfo->{$col} },
501           %{ $info->{$col} || $lc_info->{lc $col} || {} }
502         };
503       }
504     };
505   }
506
507   my %ret;
508
509   if ($columns) {
510     for (@$columns) {
511       if (my $inf = $colinfo->{$_}) {
512         $ret{$_} = $inf;
513       }
514       else {
515         $self->throw_exception( sprintf (
516           "No such column '%s' on source '%s'",
517           $_,
518           $self->source_name || $self->name || 'Unknown source...?',
519         ));
520       }
521     }
522   }
523   else {
524     %ret = %$colinfo;
525   }
526
527   return \%ret;
528 }
529
530 =head2 remove_columns
531
532 =over
533
534 =item Arguments: @colnames
535
536 =item Return Value: not defined
537
538 =back
539
540   $source->remove_columns(qw/col1 col2 col3/);
541
542 Removes the given list of columns by name, from the result source.
543
544 B<Warning>: Removing a column that is also used in the sources primary
545 key, or in one of the sources unique constraints, B<will> result in a
546 broken result source.
547
548 =head2 remove_column
549
550 =over
551
552 =item Arguments: $colname
553
554 =item Return Value: not defined
555
556 =back
557
558   $source->remove_column('col');
559
560 Remove a single column by name from the result source, similar to
561 L</remove_columns>.
562
563 B<Warning>: Removing a column that is also used in the sources primary
564 key, or in one of the sources unique constraints, B<will> result in a
565 broken result source.
566
567 =cut
568
569 sub remove_columns {
570   my ($self, @to_remove) = @_;
571
572   my $columns = $self->_columns
573     or return;
574
575   my %to_remove;
576   for (@to_remove) {
577     delete $columns->{$_};
578     ++$to_remove{$_};
579   }
580
581   $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
582 }
583
584 sub remove_column {
585   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
586   shift->remove_columns(@_)
587 }
588
589 =head2 set_primary_key
590
591 =over 4
592
593 =item Arguments: @cols
594
595 =item Return Value: not defined
596
597 =back
598
599 Defines one or more columns as primary key for this source. Must be
600 called after L</add_columns>.
601
602 Additionally, defines a L<unique constraint|/add_unique_constraint>
603 named C<primary>.
604
605 Note: you normally do want to define a primary key on your sources
606 B<even if the underlying database table does not have a primary key>.
607 See
608 L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
609 for more info.
610
611 =cut
612
613 sub set_primary_key {
614   my ($self, @cols) = @_;
615
616   my $colinfo = $self->columns_info(\@cols);
617   for my $col (@cols) {
618     carp_unique(sprintf (
619       "Primary key of source '%s' includes the column '%s' which has its "
620     . "'is_nullable' attribute set to true. This is a mistake and will cause "
621     . 'various Result-object operations to fail',
622       $self->source_name || $self->name || 'Unknown source...?',
623       $col,
624     )) if $colinfo->{$col}{is_nullable};
625   }
626
627   $self->_primaries(\@cols);
628
629   $self->add_unique_constraint(primary => \@cols);
630 }
631
632 =head2 primary_columns
633
634 =over 4
635
636 =item Arguments: none
637
638 =item Return Value: Ordered list of primary column names
639
640 =back
641
642 Read-only accessor which returns the list of primary keys, supplied by
643 L</set_primary_key>.
644
645 =cut
646
647 sub primary_columns {
648   return @{shift->_primaries||[]};
649 }
650
651 # a helper method that will automatically die with a descriptive message if
652 # no pk is defined on the source in question. For internal use to save
653 # on if @pks... boilerplate
654 sub _pri_cols_or_die {
655   my $self = shift;
656   my @pcols = $self->primary_columns
657     or $self->throw_exception (sprintf(
658       "Operation requires a primary key to be declared on '%s' via set_primary_key",
659       # source_name is set only after schema-registration
660       $self->source_name || $self->result_class || $self->name || 'Unknown source...?',
661     ));
662   return @pcols;
663 }
664
665 # same as above but mandating single-column PK (used by relationship condition
666 # inference)
667 sub _single_pri_col_or_die {
668   my $self = shift;
669   my ($pri, @too_many) = $self->_pri_cols_or_die;
670
671   $self->throw_exception( sprintf(
672     "Operation requires a single-column primary key declared on '%s'",
673     $self->source_name || $self->result_class || $self->name || 'Unknown source...?',
674   )) if @too_many;
675   return $pri;
676 }
677
678
679 =head2 sequence
680
681 Manually define the correct sequence for your table, to avoid the overhead
682 associated with looking up the sequence automatically. The supplied sequence
683 will be applied to the L</column_info> of each L<primary_key|/set_primary_key>
684
685 =over 4
686
687 =item Arguments: $sequence_name
688
689 =item Return Value: not defined
690
691 =back
692
693 =cut
694
695 sub sequence {
696   my ($self,$seq) = @_;
697
698   my @pks = $self->primary_columns
699     or return;
700
701   $_->{sequence} = $seq
702     for values %{ $self->columns_info (\@pks) };
703 }
704
705
706 =head2 add_unique_constraint
707
708 =over 4
709
710 =item Arguments: $name?, \@colnames
711
712 =item Return Value: not defined
713
714 =back
715
716 Declare a unique constraint on this source. Call once for each unique
717 constraint.
718
719   # For UNIQUE (column1, column2)
720   __PACKAGE__->add_unique_constraint(
721     constraint_name => [ qw/column1 column2/ ],
722   );
723
724 Alternatively, you can specify only the columns:
725
726   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
727
728 This will result in a unique constraint named
729 C<table_column1_column2>, where C<table> is replaced with the table
730 name.
731
732 Unique constraints are used, for example, when you pass the constraint
733 name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
734 only columns in the constraint are searched.
735
736 Throws an error if any of the given column names do not yet exist on
737 the result source.
738
739 =cut
740
741 sub add_unique_constraint {
742   my $self = shift;
743
744   if (@_ > 2) {
745     $self->throw_exception(
746         'add_unique_constraint() does not accept multiple constraints, use '
747       . 'add_unique_constraints() instead'
748     );
749   }
750
751   my $cols = pop @_;
752   if (ref $cols ne 'ARRAY') {
753     $self->throw_exception (
754       'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING')
755     );
756   }
757
758   my $name = shift @_;
759
760   $name ||= $self->name_unique_constraint($cols);
761
762   foreach my $col (@$cols) {
763     $self->throw_exception("No such column $col on table " . $self->name)
764       unless $self->has_column($col);
765   }
766
767   my %unique_constraints = $self->unique_constraints;
768   $unique_constraints{$name} = $cols;
769   $self->_unique_constraints(\%unique_constraints);
770 }
771
772 =head2 add_unique_constraints
773
774 =over 4
775
776 =item Arguments: @constraints
777
778 =item Return Value: not defined
779
780 =back
781
782 Declare multiple unique constraints on this source.
783
784   __PACKAGE__->add_unique_constraints(
785     constraint_name1 => [ qw/column1 column2/ ],
786     constraint_name2 => [ qw/column2 column3/ ],
787   );
788
789 Alternatively, you can specify only the columns:
790
791   __PACKAGE__->add_unique_constraints(
792     [ qw/column1 column2/ ],
793     [ qw/column3 column4/ ]
794   );
795
796 This will result in unique constraints named C<table_column1_column2> and
797 C<table_column3_column4>, where C<table> is replaced with the table name.
798
799 Throws an error if any of the given column names do not yet exist on
800 the result source.
801
802 See also L</add_unique_constraint>.
803
804 =cut
805
806 sub add_unique_constraints {
807   my $self = shift;
808   my @constraints = @_;
809
810   if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) {
811     # with constraint name
812     while (my ($name, $constraint) = splice @constraints, 0, 2) {
813       $self->add_unique_constraint($name => $constraint);
814     }
815   }
816   else {
817     # no constraint name
818     foreach my $constraint (@constraints) {
819       $self->add_unique_constraint($constraint);
820     }
821   }
822 }
823
824 =head2 name_unique_constraint
825
826 =over 4
827
828 =item Arguments: \@colnames
829
830 =item Return Value: Constraint name
831
832 =back
833
834   $source->table('mytable');
835   $source->name_unique_constraint(['col1', 'col2']);
836   # returns
837   'mytable_col1_col2'
838
839 Return a name for a unique constraint containing the specified
840 columns. The name is created by joining the table name and each column
841 name, using an underscore character.
842
843 For example, a constraint on a table named C<cd> containing the columns
844 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
845
846 This is used by L</add_unique_constraint> if you do not specify the
847 optional constraint name.
848
849 =cut
850
851 sub name_unique_constraint {
852   my ($self, $cols) = @_;
853
854   my $name = $self->name;
855   $name = $$name if (ref $name eq 'SCALAR');
856   $name =~ s/ ^ [^\.]+ \. //x;  # strip possible schema qualifier
857
858   return join '_', $name, @$cols;
859 }
860
861 =head2 unique_constraints
862
863 =over 4
864
865 =item Arguments: none
866
867 =item Return Value: Hash of unique constraint data
868
869 =back
870
871   $source->unique_constraints();
872
873 Read-only accessor which returns a hash of unique constraints on this
874 source.
875
876 The hash is keyed by constraint name, and contains an arrayref of
877 column names as values.
878
879 =cut
880
881 sub unique_constraints {
882   return %{shift->_unique_constraints||{}};
883 }
884
885 =head2 unique_constraint_names
886
887 =over 4
888
889 =item Arguments: none
890
891 =item Return Value: Unique constraint names
892
893 =back
894
895   $source->unique_constraint_names();
896
897 Returns the list of unique constraint names defined on this source.
898
899 =cut
900
901 sub unique_constraint_names {
902   my ($self) = @_;
903
904   my %unique_constraints = $self->unique_constraints;
905
906   return keys %unique_constraints;
907 }
908
909 =head2 unique_constraint_columns
910
911 =over 4
912
913 =item Arguments: $constraintname
914
915 =item Return Value: List of constraint columns
916
917 =back
918
919   $source->unique_constraint_columns('myconstraint');
920
921 Returns the list of columns that make up the specified unique constraint.
922
923 =cut
924
925 sub unique_constraint_columns {
926   my ($self, $constraint_name) = @_;
927
928   my %unique_constraints = $self->unique_constraints;
929
930   $self->throw_exception(
931     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
932   ) unless exists $unique_constraints{$constraint_name};
933
934   return @{ $unique_constraints{$constraint_name} };
935 }
936
937 =head2 sqlt_deploy_callback
938
939 =over
940
941 =item Arguments: $callback_name | \&callback_code
942
943 =item Return Value: $callback_name | \&callback_code
944
945 =back
946
947   __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod');
948
949    or
950
951   __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub {
952     my ($source_instance, $sqlt_table) = @_;
953     ...
954   } );
955
956 An accessor to set a callback to be called during deployment of
957 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
958 L<DBIx::Class::Schema/deploy>.
959
960 The callback can be set as either a code reference or the name of a
961 method in the current result class.
962
963 Defaults to L</default_sqlt_deploy_hook>.
964
965 Your callback will be passed the $source object representing the
966 ResultSource instance being deployed, and the
967 L<SQL::Translator::Schema::Table> object being created from it. The
968 callback can be used to manipulate the table object or add your own
969 customised indexes. If you need to manipulate a non-table object, use
970 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
971
972 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
973 Your SQL> for examples.
974
975 This sqlt deployment callback can only be used to manipulate
976 SQL::Translator objects as they get turned into SQL. To execute
977 post-deploy statements which SQL::Translator does not currently
978 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
979 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
980
981 =head2 default_sqlt_deploy_hook
982
983 This is the default deploy hook implementation which checks if your
984 current Result class has a C<sqlt_deploy_hook> method, and if present
985 invokes it B<on the Result class directly>. This is to preserve the
986 semantics of C<sqlt_deploy_hook> which was originally designed to expect
987 the Result class name and the
988 L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being
989 deployed.
990
991 =cut
992
993 sub default_sqlt_deploy_hook {
994   my $self = shift;
995
996   my $class = $self->result_class;
997
998   if ($class and $class->can('sqlt_deploy_hook')) {
999     $class->sqlt_deploy_hook(@_);
1000   }
1001 }
1002
1003 sub _invoke_sqlt_deploy_hook {
1004   my $self = shift;
1005   if ( my $hook = $self->sqlt_deploy_callback) {
1006     $self->$hook(@_);
1007   }
1008 }
1009
1010 =head2 result_class
1011
1012 =over 4
1013
1014 =item Arguments: $classname
1015
1016 =item Return Value: $classname
1017
1018 =back
1019
1020  use My::Schema::ResultClass::Inflator;
1021  ...
1022
1023  use My::Schema::Artist;
1024  ...
1025  __PACKAGE__->result_class('My::Schema::ResultClass::Inflator');
1026
1027 Set the default result class for this source. You can use this to create
1028 and use your own result inflator. See L<DBIx::Class::ResultSet/result_class>
1029 for more details.
1030
1031 Please note that setting this to something like
1032 L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed
1033 and make life more difficult.  Inflators like those are better suited to
1034 temporary usage via L<DBIx::Class::ResultSet/result_class>.
1035
1036 =head2 resultset
1037
1038 =over 4
1039
1040 =item Arguments: none
1041
1042 =item Return Value: L<$resultset|DBIx::Class::ResultSet>
1043
1044 =back
1045
1046 Returns a resultset for the given source. This will initially be created
1047 on demand by calling
1048
1049   $self->resultset_class->new($self, $self->resultset_attributes)
1050
1051 but is cached from then on unless resultset_class changes.
1052
1053 =head2 resultset_class
1054
1055 =over 4
1056
1057 =item Arguments: $classname
1058
1059 =item Return Value: $classname
1060
1061 =back
1062
1063   package My::Schema::ResultSet::Artist;
1064   use base 'DBIx::Class::ResultSet';
1065   ...
1066
1067   # In the result class
1068   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
1069
1070   # Or in code
1071   $source->resultset_class('My::Schema::ResultSet::Artist');
1072
1073 Set the class of the resultset. This is useful if you want to create your
1074 own resultset methods. Create your own class derived from
1075 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1076 this method returns the name of the existing resultset class, if one
1077 exists.
1078
1079 =head2 resultset_attributes
1080
1081 =over 4
1082
1083 =item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1084
1085 =item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1086
1087 =back
1088
1089   # In the result class
1090   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
1091
1092   # Or in code
1093   $source->resultset_attributes({ order_by => [ 'id' ] });
1094
1095 Store a collection of resultset attributes, that will be set on every
1096 L<DBIx::Class::ResultSet> produced from this result source.
1097
1098 B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and
1099 bugs! While C<resultset_attributes> isn't deprecated per se, its usage is
1100 not recommended!
1101
1102 Since relationships use attributes to link tables together, the "default"
1103 attributes you set may cause unpredictable and undesired behavior.  Furthermore,
1104 the defaults cannot be turned off, so you are stuck with them.
1105
1106 In most cases, what you should actually be using are project-specific methods:
1107
1108   package My::Schema::ResultSet::Artist;
1109   use base 'DBIx::Class::ResultSet';
1110   ...
1111
1112   # BAD IDEA!
1113   #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' });
1114
1115   # GOOD IDEA!
1116   sub with_tracks { shift->search({}, { prefetch => 'tracks' }) }
1117
1118   # in your code
1119   $schema->resultset('Artist')->with_tracks->...
1120
1121 This gives you the flexibility of not using it when you don't need it.
1122
1123 For more complex situations, another solution would be to use a virtual view
1124 via L<DBIx::Class::ResultSource::View>.
1125
1126 =cut
1127
1128 sub resultset {
1129   my $self = shift;
1130   $self->throw_exception(
1131     'resultset does not take any arguments. If you want another resultset, '.
1132     'call it on the schema instead.'
1133   ) if scalar @_;
1134
1135   $self->resultset_class->new(
1136     $self,
1137     {
1138       ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ),
1139       %{$self->{resultset_attributes}},
1140     },
1141   );
1142 }
1143
1144 =head2 name
1145
1146 =over 4
1147
1148 =item Arguments: none
1149
1150 =item Result value: $name
1151
1152 =back
1153
1154 Returns the name of the result source, which will typically be the table
1155 name. This may be a scalar reference if the result source has a non-standard
1156 name.
1157
1158 =head2 source_name
1159
1160 =over 4
1161
1162 =item Arguments: $source_name
1163
1164 =item Result value: $source_name
1165
1166 =back
1167
1168 Set an alternate name for the result source when it is loaded into a schema.
1169 This is useful if you want to refer to a result source by a name other than
1170 its class name.
1171
1172   package ArchivedBooks;
1173   use base qw/DBIx::Class/;
1174   __PACKAGE__->table('books_archive');
1175   __PACKAGE__->source_name('Books');
1176
1177   # from your schema...
1178   $schema->resultset('Books')->find(1);
1179
1180 =head2 from
1181
1182 =over 4
1183
1184 =item Arguments: none
1185
1186 =item Return Value: FROM clause
1187
1188 =back
1189
1190   my $from_clause = $source->from();
1191
1192 Returns an expression of the source to be supplied to storage to specify
1193 retrieval from this source. In the case of a database, the required FROM
1194 clause contents.
1195
1196 =cut
1197
1198 sub from { die 'Virtual method!' }
1199
1200 =head2 source_info
1201
1202 Stores a hashref of per-source metadata.  No specific key names
1203 have yet been standardized, the examples below are purely hypothetical
1204 and don't actually accomplish anything on their own:
1205
1206   __PACKAGE__->source_info({
1207     "_tablespace" => 'fast_disk_array_3',
1208     "_engine" => 'InnoDB',
1209   });
1210
1211 =head2 schema
1212
1213 =over 4
1214
1215 =item Arguments: L<$schema?|DBIx::Class::Schema>
1216
1217 =item Return Value: L<$schema|DBIx::Class::Schema>
1218
1219 =back
1220
1221   my $schema = $source->schema();
1222
1223 Sets and/or returns the L<DBIx::Class::Schema> object to which this
1224 result source instance has been attached to.
1225
1226 =cut
1227
1228 sub schema {
1229   if (@_ > 1) {
1230     $_[0]->{schema} = $_[1];
1231   }
1232   else {
1233     $_[0]->{schema} || do {
1234       my $name = $_[0]->{source_name} || '_unnamed_';
1235       my $err = 'Unable to perform storage-dependent operations with a detached result source '
1236               . "(source '$name' is not associated with a schema).";
1237
1238       $err .= ' You need to use $schema->thaw() or manually set'
1239             . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
1240         if $_[0]->{_detached_thaw};
1241
1242       DBIx::Class::Exception->throw($err);
1243     };
1244   }
1245 }
1246
1247 =head2 storage
1248
1249 =over 4
1250
1251 =item Arguments: none
1252
1253 =item Return Value: L<$storage|DBIx::Class::Storage>
1254
1255 =back
1256
1257   $source->storage->debug(1);
1258
1259 Returns the L<storage handle|DBIx::Class::Storage> for the current schema.
1260
1261 =cut
1262
1263 sub storage {
1264   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
1265   $_[0]->schema->storage
1266 }
1267
1268 =head2 add_relationship
1269
1270 =over 4
1271
1272 =item Arguments: $rel_name, $related_source_name, \%cond, \%attrs?
1273
1274 =item Return Value: 1/true if it succeeded
1275
1276 =back
1277
1278   $source->add_relationship('rel_name', 'related_source', $cond, $attrs);
1279
1280 L<DBIx::Class::Relationship> describes a series of methods which
1281 create pre-defined useful types of relationships. Look there first
1282 before using this method directly.
1283
1284 The relationship name can be arbitrary, but must be unique for each
1285 relationship attached to this result source. 'related_source' should
1286 be the name with which the related result source was registered with
1287 the current schema. For example:
1288
1289   $schema->source('Book')->add_relationship('reviews', 'Review', {
1290     'foreign.book_id' => 'self.id',
1291   });
1292
1293 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1294 representation of the join between the tables. For example, if you're
1295 creating a relation from Author to Book,
1296
1297   { 'foreign.author_id' => 'self.id' }
1298
1299 will result in the JOIN clause
1300
1301   author me JOIN book foreign ON foreign.author_id = me.id
1302
1303 You can specify as many foreign => self mappings as necessary.
1304
1305 Valid attributes are as follows:
1306
1307 =over 4
1308
1309 =item join_type
1310
1311 Explicitly specifies the type of join to use in the relationship. Any
1312 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1313 the SQL command immediately before C<JOIN>.
1314
1315 =item proxy
1316
1317 An arrayref containing a list of accessors in the foreign class to proxy in
1318 the main class. If, for example, you do the following:
1319
1320   CD->might_have(liner_notes => 'LinerNotes', undef, {
1321     proxy => [ qw/notes/ ],
1322   });
1323
1324 Then, assuming LinerNotes has an accessor named notes, you can do:
1325
1326   my $cd = CD->find(1);
1327   # set notes -- LinerNotes object is created if it doesn't exist
1328   $cd->notes('Notes go here');
1329
1330 =item accessor
1331
1332 Specifies the type of accessor that should be created for the
1333 relationship. Valid values are C<single> (for when there is only a single
1334 related object), C<multi> (when there can be many), and C<filter> (for
1335 when there is a single related object, but you also want the relationship
1336 accessor to double as a column accessor). For C<multi> accessors, an
1337 add_to_* method is also created, which calls C<create_related> for the
1338 relationship.
1339
1340 =back
1341
1342 Throws an exception if the condition is improperly supplied, or cannot
1343 be resolved.
1344
1345 =cut
1346
1347 sub add_relationship {
1348   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1349   $self->throw_exception("Can't create relationship without join condition")
1350     unless $cond;
1351   $attrs ||= {};
1352
1353   # Check foreign and self are right in cond
1354   if ( (ref $cond ||'') eq 'HASH') {
1355     $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'")
1356       for keys %$cond;
1357
1358     $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'")
1359       for values %$cond;
1360   }
1361
1362   my %rels = %{ $self->_relationships };
1363   $rels{$rel} = { class => $f_source_name,
1364                   source => $f_source_name,
1365                   cond  => $cond,
1366                   attrs => $attrs };
1367   $self->_relationships(\%rels);
1368
1369   return $self;
1370 }
1371
1372 =head2 relationships
1373
1374 =over 4
1375
1376 =item Arguments: none
1377
1378 =item Return Value: L<@rel_names|DBIx::Class::Relationship>
1379
1380 =back
1381
1382   my @rel_names = $source->relationships();
1383
1384 Returns all relationship names for this source.
1385
1386 =cut
1387
1388 sub relationships {
1389   keys %{$_[0]->_relationships};
1390 }
1391
1392 =head2 relationship_info
1393
1394 =over 4
1395
1396 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1397
1398 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1399
1400 =back
1401
1402 Returns a hash of relationship information for the specified relationship
1403 name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>.
1404
1405 =cut
1406
1407 sub relationship_info {
1408   #my ($self, $rel) = @_;
1409   return shift->_relationships->{+shift};
1410 }
1411
1412 =head2 has_relationship
1413
1414 =over 4
1415
1416 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1417
1418 =item Return Value: 1/0 (true/false)
1419
1420 =back
1421
1422 Returns true if the source has a relationship of this name, false otherwise.
1423
1424 =cut
1425
1426 sub has_relationship {
1427   #my ($self, $rel) = @_;
1428   return exists shift->_relationships->{+shift};
1429 }
1430
1431 =head2 reverse_relationship_info
1432
1433 =over 4
1434
1435 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1436
1437 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1438
1439 =back
1440
1441 Looks through all the relationships on the source this relationship
1442 points to, looking for one whose condition is the reverse of the
1443 condition on this relationship.
1444
1445 A common use of this is to find the name of the C<belongs_to> relation
1446 opposing a C<has_many> relation. For definition of these look in
1447 L<DBIx::Class::Relationship>.
1448
1449 The returned hashref is keyed by the name of the opposing
1450 relationship, and contains its data in the same manner as
1451 L</relationship_info>.
1452
1453 =cut
1454
1455 sub reverse_relationship_info {
1456   my ($self, $rel) = @_;
1457
1458   my $rel_info = $self->relationship_info($rel)
1459     or $self->throw_exception("No such relationship '$rel'");
1460
1461   my $ret = {};
1462
1463   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1464
1465   my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
1466
1467   my $registered_source_name = $self->source_name;
1468
1469   # this may be a partial schema or something else equally esoteric
1470   my $other_rsrc = $self->related_source($rel);
1471
1472   # Get all the relationships for that source that related to this source
1473   # whose foreign column set are our self columns on $rel and whose self
1474   # columns are our foreign columns on $rel
1475   foreach my $other_rel ($other_rsrc->relationships) {
1476
1477     # only consider stuff that points back to us
1478     # "us" here is tricky - if we are in a schema registration, we want
1479     # to use the source_names, otherwise we will use the actual classes
1480
1481     # the schema may be partial
1482     my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
1483       or next;
1484
1485     if ($registered_source_name) {
1486       next if $registered_source_name ne ($roundtrip_rsrc->source_name || '')
1487     }
1488     else {
1489       next if $self->result_class ne $roundtrip_rsrc->result_class;
1490     }
1491
1492     my $other_rel_info = $other_rsrc->relationship_info($other_rel);
1493
1494     # this can happen when we have a self-referential class
1495     next if $other_rel_info eq $rel_info;
1496
1497     next unless ref $other_rel_info->{cond} eq 'HASH';
1498     my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
1499
1500     $ret->{$other_rel} = $other_rel_info if (
1501       $self->_compare_relationship_keys (
1502         [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
1503       )
1504         and
1505       $self->_compare_relationship_keys (
1506         [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
1507       )
1508     );
1509   }
1510
1511   return $ret;
1512 }
1513
1514 # all this does is removes the foreign/self prefix from a condition
1515 sub __strip_relcond {
1516   +{
1517     map
1518       { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
1519       keys %{$_[1]}
1520   }
1521 }
1522
1523 sub compare_relationship_keys {
1524   carp 'compare_relationship_keys is a private method, stop calling it';
1525   my $self = shift;
1526   $self->_compare_relationship_keys (@_);
1527 }
1528
1529 # Returns true if both sets of keynames are the same, false otherwise.
1530 sub _compare_relationship_keys {
1531 #  my ($self, $keys1, $keys2) = @_;
1532   return
1533     join ("\x00", sort @{$_[1]})
1534       eq
1535     join ("\x00", sort @{$_[2]})
1536   ;
1537 }
1538
1539 # optionally takes either an arrayref of column names, or a hashref of already
1540 # retrieved colinfos
1541 # returns an arrayref of column names of the shortest unique constraint
1542 # (matching some of the input if any), giving preference to the PK
1543 sub _identifying_column_set {
1544   my ($self, $cols) = @_;
1545
1546   my %unique = $self->unique_constraints;
1547   my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||());
1548
1549   # always prefer the PK first, and then shortest constraints first
1550   USET:
1551   for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) {
1552     next unless $set && @$set;
1553
1554     for (@$set) {
1555       next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} );
1556     }
1557
1558     # copy so we can mangle it at will
1559     return [ @$set ];
1560   }
1561
1562   return undef;
1563 }
1564
1565 sub _minimal_valueset_satisfying_constraint {
1566   my $self = shift;
1567   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1568
1569   $args->{columns_info} ||= $self->columns_info;
1570
1571   my $vals = $self->schema->storage->_extract_fixed_condition_columns(
1572     $args->{values},
1573     ($args->{carp_on_nulls} ? 'consider_nulls' : undef ),
1574   );
1575
1576   my $cols;
1577   for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) {
1578     if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) {
1579       $cols->{missing}{$col} = undef;
1580     }
1581     elsif( ! defined $vals->{$col} ) {
1582       $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef;
1583     }
1584     else {
1585       # we need to inject back the '=' as _extract_fixed_condition_columns
1586       # will strip it from literals and values alike, resulting in an invalid
1587       # condition in the end
1588       $cols->{present}{$col} = { '=' => $vals->{$col} };
1589     }
1590
1591     $cols->{fc}{$col} = 1 if (
1592       ( ! $cols->{missing} or ! exists $cols->{missing}{$col} )
1593         and
1594       keys %{ $args->{columns_info}{$col}{_filter_info} || {} }
1595     );
1596   }
1597
1598   $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s",
1599     $args->{constraint_name},
1600     join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ),
1601   ) ) if $cols->{missing};
1602
1603   $self->throw_exception( sprintf (
1604     "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s",
1605     $args->{constraint_name},
1606     join (', ', map { "'$_'" } sort keys %{$cols->{fc}}),
1607   )) if $cols->{fc};
1608
1609   if (
1610     $cols->{undefined}
1611       and
1612     !$ENV{DBIC_NULLABLE_KEY_NOWARN}
1613   ) {
1614     carp_unique ( sprintf (
1615       "NULL/undef values supplied for requested unique constraint '%s' (NULL "
1616     . 'values in column(s): %s). This is almost certainly not what you wanted, '
1617     . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
1618       $args->{constraint_name},
1619       join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}),
1620     ));
1621   }
1622
1623   return { map { %{ $cols->{$_}||{} } } qw(present undefined) };
1624 }
1625
1626 # Returns the {from} structure used to express JOIN conditions
1627 sub _resolve_join {
1628   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1629
1630   # we need a supplied one, because we do in-place modifications, no returns
1631   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1632     unless ref $seen eq 'HASH';
1633
1634   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1635     unless ref $jpath eq 'ARRAY';
1636
1637   $jpath = [@$jpath]; # copy
1638
1639   if (not defined $join or not length $join) {
1640     return ();
1641   }
1642   elsif (ref $join eq 'ARRAY') {
1643     return
1644       map {
1645         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1646       } @$join;
1647   }
1648   elsif (ref $join eq 'HASH') {
1649
1650     my @ret;
1651     for my $rel (keys %$join) {
1652
1653       my $rel_info = $self->relationship_info($rel)
1654         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1655
1656       my $force_left = $parent_force_left;
1657       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1658
1659       # the actual seen value will be incremented by the recursion
1660       my $as = $self->schema->storage->relname_to_table_alias(
1661         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1662       );
1663
1664       push @ret, (
1665         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1666         $self->related_source($rel)->_resolve_join(
1667           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1668         )
1669       );
1670     }
1671     return @ret;
1672
1673   }
1674   elsif (ref $join) {
1675     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1676   }
1677   else {
1678     my $count = ++$seen->{$join};
1679     my $as = $self->schema->storage->relname_to_table_alias(
1680       $join, ($count > 1 && $count)
1681     );
1682
1683     my $rel_info = $self->relationship_info($join)
1684       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1685
1686     my $rel_src = $self->related_source($join);
1687     return [ { $as => $rel_src->from,
1688                -rsrc => $rel_src,
1689                -join_type => $parent_force_left
1690                   ? 'left'
1691                   : $rel_info->{attrs}{join_type}
1692                 ,
1693                -join_path => [@$jpath, { $join => $as } ],
1694                -is_single => (
1695                   ! $rel_info->{attrs}{accessor}
1696                     or
1697                   $rel_info->{attrs}{accessor} eq 'single'
1698                     or
1699                   $rel_info->{attrs}{accessor} eq 'filter'
1700                 ),
1701                -alias => $as,
1702                -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1,
1703              },
1704              $self->_resolve_relationship_condition(
1705                rel_name => $join,
1706                self_alias => $alias,
1707                foreign_alias => $as,
1708              )->{condition},
1709           ];
1710   }
1711 }
1712
1713 sub pk_depends_on {
1714   carp 'pk_depends_on is a private method, stop calling it';
1715   my $self = shift;
1716   $self->_pk_depends_on (@_);
1717 }
1718
1719 # Determines whether a relation is dependent on an object from this source
1720 # having already been inserted. Takes the name of the relationship and a
1721 # hashref of columns of the related object.
1722 sub _pk_depends_on {
1723   my ($self, $rel_name, $rel_data) = @_;
1724
1725   my $relinfo = $self->relationship_info($rel_name);
1726
1727   # don't assume things if the relationship direction is specified
1728   return $relinfo->{attrs}{is_foreign_key_constraint}
1729     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1730
1731   my $cond = $relinfo->{cond};
1732   return 0 unless ref($cond) eq 'HASH';
1733
1734   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1735   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1736
1737   # assume anything that references our PK probably is dependent on us
1738   # rather than vice versa, unless the far side is (a) defined or (b)
1739   # auto-increment
1740   my $rel_source = $self->related_source($rel_name);
1741
1742   foreach my $p ($self->primary_columns) {
1743     if (exists $keyhash->{$p}) {
1744       unless (defined($rel_data->{$keyhash->{$p}})
1745               || $rel_source->column_info($keyhash->{$p})
1746                             ->{is_auto_increment}) {
1747         return 0;
1748       }
1749     }
1750   }
1751
1752   return 1;
1753 }
1754
1755 sub resolve_condition {
1756   carp 'resolve_condition is a private method, stop calling it';
1757   shift->_resolve_condition (@_);
1758 }
1759
1760 sub _resolve_condition {
1761 #  carp_unique sprintf
1762 #    '_resolve_condition is a private method, and moreover is about to go '
1763 #  . 'away. Please contact the development team at %s if you believe you '
1764 #  . 'have a genuine use for this method, in order to discuss alternatives.',
1765 #    DBIx::Class::_ENV_::HELP_URL,
1766 #  ;
1767
1768 #######################
1769 ### API Design? What's that...? (a backwards compatible shim, kill me now)
1770
1771   my ($self, $cond, @res_args, $rel_name);
1772
1773   # we *SIMPLY DON'T KNOW YET* which arg is which, yay
1774   ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_;
1775
1776   # assume that an undef is an object-like unset (set_from_related(undef))
1777   my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args);
1778
1779   # turn objlike into proper objects for saner code further down
1780   for (0,1) {
1781     next unless $is_objlike[$_];
1782
1783     if ( defined blessed $res_args[$_] ) {
1784
1785       # but wait - there is more!!! WHAT THE FUCK?!?!?!?!
1786       if ($res_args[$_]->isa('DBIx::Class::ResultSet')) {
1787         carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__');
1788         $is_objlike[$_] = 0;
1789         $res_args[$_] = '__gremlins__';
1790       }
1791     }
1792     else {
1793       $res_args[$_] ||= {};
1794
1795       # hate everywhere - have to pass in as a plain hash
1796       # pretending to be an object at least for now
1797       $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]")
1798         unless ref $res_args[$_] eq 'HASH';
1799     }
1800   }
1801
1802   my $args = {
1803     # where-is-waldo block guesses relname, then further down we override it if available
1804     (
1805       $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me',         self_result_object  => $res_args[1] )
1806     : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me',         foreign_alias => $res_args[1], foreign_values      => $res_args[0] )
1807     :                  ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0]                                      )
1808     ),
1809
1810     ( $rel_name ? ( rel_name => $rel_name ) : () ),
1811   };
1812
1813   # Allowing passing relconds different than the relationshup itself is cute,
1814   # but likely dangerous. Remove that from the (still unofficial) API of
1815   # _resolve_relationship_condition, and instead make it "hard on purpose"
1816   local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond;
1817
1818 #######################
1819
1820   # now it's fucking easy isn't it?!
1821   my $rc = $self->_resolve_relationship_condition( $args );
1822
1823   my @res = (
1824     ( $rc->{join_free_condition} || $rc->{condition} ),
1825     ! $rc->{join_free_condition},
1826   );
1827
1828   # _resolve_relationship_condition always returns qualified cols even in the
1829   # case of join_free_condition, but nothing downstream expects this
1830   if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') {
1831     $res[0] = { map
1832       { ($_ =~ /\.(.+)/) => $res[0]{$_} }
1833       keys %{$res[0]}
1834     };
1835   }
1836
1837   # and more legacy
1838   return wantarray ? @res : $res[0];
1839 }
1840
1841 # Keep this indefinitely. There is evidence of both CPAN and
1842 # darkpan using it, and there isn't much harm in an extra var
1843 # anyway.
1844 our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION;
1845 # YES I KNOW THIS IS EVIL
1846 # it is there to save darkpan from themselves, since internally
1847 # we are moving to a constant
1848 Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1);
1849
1850 # Resolves the passed condition to a concrete query fragment and extra
1851 # metadata
1852 #
1853 ## self-explanatory API, modeled on the custom cond coderef:
1854 # rel_name              => (scalar)
1855 # foreign_alias         => (scalar)
1856 # foreign_values        => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef )
1857 # self_alias            => (scalar)
1858 # self_result_object    => (either not supplied or a result object)
1859 # require_join_free_condition => (boolean, throws on failure to construct a JF-cond)
1860 # infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition)
1861 #
1862 ## returns a hash
1863 # condition           => (a valid *likely fully qualified* sqla cond structure)
1864 # identity_map        => (a hashref of foreign-to-self *unqualified* column equality names)
1865 # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset)
1866 # inferred_values     => (in case of an available join_free condition, this is a hashref of
1867 #                         *unqualified* column/value *EQUALITY* pairs, representing an amalgamation
1868 #                         of the JF-cond parse and infer_values_based_on
1869 #                         always either complete or unset)
1870 #
1871 sub _resolve_relationship_condition {
1872   my $self = shift;
1873
1874   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1875
1876   for ( qw( rel_name self_alias foreign_alias ) ) {
1877     $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string")
1878       if !defined $args->{$_} or length ref $args->{$_};
1879   }
1880
1881   $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical")
1882     if $args->{self_alias} eq $args->{foreign_alias};
1883
1884 # TEMP
1885   my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'";
1886
1887   my $rel_info = $self->relationship_info($args->{rel_name})
1888 # TEMP
1889 #    or $self->throw_exception( "No such $exception_rel_id" );
1890     or carp_unique("Requesting resolution on non-existent relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}': fix your code *soon*, as it will break with the next major version");
1891
1892 # TEMP
1893   $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'"
1894     if $rel_info and exists $rel_info->{_original_name};
1895
1896   $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures")
1897     if exists $args->{self_result_object} and exists $args->{foreign_values};
1898
1899   $self->throw_exception( "Argument to infer_values_based_on must be a hash" )
1900     if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH';
1901
1902   $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on};
1903
1904   $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" )
1905     if (
1906       exists $args->{self_result_object}
1907         and
1908       ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') )
1909     )
1910   ;
1911
1912   my $rel_rsrc = $self->related_source($args->{rel_name});
1913   my $storage = $self->schema->storage;
1914
1915   if (exists $args->{foreign_values}) {
1916
1917     if (! defined $args->{foreign_values} ) {
1918       # fallback: undef => {}
1919       $args->{foreign_values} = {};
1920     }
1921     elsif (defined blessed $args->{foreign_values}) {
1922
1923       $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" )
1924         unless $args->{foreign_values}->isa('DBIx::Class::Row');
1925
1926       carp_unique(
1927         "Objects supplied as 'foreign_values' ($args->{foreign_values}) "
1928       . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), "
1929       . "perhaps you've made a mistake invoking the condition resolver?"
1930       ) unless $args->{foreign_values}->isa($rel_rsrc->result_class);
1931
1932       $args->{foreign_values} = { $args->{foreign_values}->get_columns };
1933     }
1934     elsif ( ref $args->{foreign_values} eq 'HASH' ) {
1935
1936       # re-build {foreign_values} excluding identically named rels
1937       if( keys %{$args->{foreign_values}} ) {
1938
1939         my ($col_idx, $rel_idx) = map
1940           { { map { $_ => 1 } $rel_rsrc->$_ } }
1941           qw( columns relationships )
1942         ;
1943
1944         my $equivalencies = $storage->_extract_fixed_condition_columns(
1945           $args->{foreign_values},
1946           'consider nulls',
1947         );
1948
1949         $args->{foreign_values} = { map {
1950           # skip if relationship *and* a non-literal ref
1951           # this means a multicreate stub was passed in
1952           (
1953             $rel_idx->{$_}
1954               and
1955             length ref $args->{foreign_values}{$_}
1956               and
1957             ! is_literal_value($args->{foreign_values}{$_})
1958           )
1959             ? ()
1960             : ( $_ => (
1961                 ! $col_idx->{$_}
1962                   ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" )
1963               : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION )
1964                   ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" )
1965               : $args->{foreign_values}{$_}
1966             ))
1967         } keys %{$args->{foreign_values}} };
1968       }
1969     }
1970     else {
1971       $self->throw_exception(
1972         "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', "
1973       . "or a hash reference, or undef"
1974       );
1975     }
1976   }
1977
1978   my $ret;
1979
1980   if (ref $rel_info->{cond} eq 'CODE') {
1981
1982     my $cref_args = {
1983       rel_name => $args->{rel_name},
1984       self_resultsource => $self,
1985       self_alias => $args->{self_alias},
1986       foreign_alias => $args->{foreign_alias},
1987       ( map
1988         { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () }
1989         qw( self_result_object foreign_values )
1990       ),
1991     };
1992
1993     # legacy - never remove these!!!
1994     $cref_args->{foreign_relname} = $cref_args->{rel_name};
1995
1996     $cref_args->{self_rowobj} = $cref_args->{self_result_object}
1997       if exists $cref_args->{self_result_object};
1998
1999     ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $rel_info->{cond}->($cref_args);
2000
2001     # sanity check
2002     $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra")
2003       if @extra;
2004
2005     if (my $jfc = $ret->{join_free_condition}) {
2006
2007       $self->throw_exception (
2008         "The join-free condition returned for $exception_rel_id must be a hash reference"
2009       ) unless ref $jfc eq 'HASH';
2010
2011       my ($joinfree_alias, $joinfree_source);
2012       if (defined $args->{self_result_object}) {
2013         $joinfree_alias = $args->{foreign_alias};
2014         $joinfree_source = $rel_rsrc;
2015       }
2016       elsif (defined $args->{foreign_values}) {
2017         $joinfree_alias = $args->{self_alias};
2018         $joinfree_source = $self;
2019       }
2020
2021       # FIXME sanity check until things stabilize, remove at some point
2022       $self->throw_exception (
2023         "A join-free condition returned for $exception_rel_id without a result object to chain from"
2024       ) unless $joinfree_alias;
2025
2026       my $fq_col_list = { map
2027         { ( "$joinfree_alias.$_" => 1 ) }
2028         $joinfree_source->columns
2029       };
2030
2031       exists $fq_col_list->{$_} or $self->throw_exception (
2032         "The join-free condition returned for $exception_rel_id may only "
2033       . 'contain keys that are fully qualified column names of the corresponding source '
2034       . "'$joinfree_alias' (instead it returned '$_')"
2035       ) for keys %$jfc;
2036
2037       (
2038         length ref $_
2039           and
2040         defined blessed($_)
2041           and
2042         $_->isa('DBIx::Class::Row')
2043           and
2044         $self->throw_exception (
2045           "The join-free condition returned for $exception_rel_id may not "
2046         . 'contain result objects as values - perhaps instead of invoking '
2047         . '->$something you meant to return ->get_column($something)'
2048         )
2049       ) for values %$jfc;
2050
2051     }
2052   }
2053   elsif (ref $rel_info->{cond} eq 'HASH') {
2054
2055     # the condition is static - use parallel arrays
2056     # for a "pivot" depending on which side of the
2057     # rel did we get as an object
2058     my (@f_cols, @l_cols);
2059     for my $fc (keys %{ $rel_info->{cond} }) {
2060       my $lc = $rel_info->{cond}{$fc};
2061
2062       # FIXME STRICTMODE should probably check these are valid columns
2063       $fc =~ s/^foreign\.// ||
2064         $self->throw_exception("Invalid rel cond key '$fc'");
2065
2066       $lc =~ s/^self\.// ||
2067         $self->throw_exception("Invalid rel cond val '$lc'");
2068
2069       push @f_cols, $fc;
2070       push @l_cols, $lc;
2071     }
2072
2073     # construct the crosstable condition and the identity map
2074     for  (0..$#f_cols) {
2075       $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" };
2076       $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_];
2077     };
2078
2079     if ($args->{foreign_values}) {
2080       $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]}
2081         for 0..$#f_cols;
2082     }
2083     elsif (defined $args->{self_result_object}) {
2084
2085       for my $i (0..$#l_cols) {
2086         if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) {
2087           $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]);
2088         }
2089         else {
2090           $self->throw_exception(sprintf
2091             "Unable to resolve relationship '%s' from object '%s': column '%s' not "
2092           . 'loaded from storage (or not passed to new() prior to insert()). You '
2093           . 'probably need to call ->discard_changes to get the server-side defaults '
2094           . 'from the database.',
2095             $args->{rel_name},
2096             $args->{self_result_object},
2097             $l_cols[$i],
2098           ) if $args->{self_result_object}->in_storage;
2099
2100           # FIXME - temporarly force-override
2101           delete $args->{require_join_free_condition};
2102           $ret->{join_free_condition} = UNRESOLVABLE_CONDITION;
2103           last;
2104         }
2105       }
2106     }
2107   }
2108   elsif (ref $rel_info->{cond} eq 'ARRAY') {
2109     if (@{ $rel_info->{cond} } == 0) {
2110       $ret = {
2111         condition => UNRESOLVABLE_CONDITION,
2112         join_free_condition => UNRESOLVABLE_CONDITION,
2113       };
2114     }
2115     else {
2116       my @subconds = map {
2117         local $rel_info->{cond} = $_;
2118         $self->_resolve_relationship_condition( $args );
2119       } @{ $rel_info->{cond} };
2120
2121       if( @{ $rel_info->{cond} } == 1 ) {
2122         $ret = $subconds[0];
2123       }
2124       else {
2125         # we are discarding inferred values here... likely incorrect...
2126         # then again - the entire thing is an OR, so we *can't* use them anyway
2127         for my $subcond ( @subconds ) {
2128           $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition')
2129             if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) );
2130
2131           $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition));
2132         }
2133       }
2134     }
2135   }
2136   else {
2137     $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :(");
2138   }
2139
2140   if (
2141     $args->{require_join_free_condition}
2142       and
2143     ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION )
2144   ) {
2145     $self->throw_exception(
2146       ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment",
2147         exists $args->{foreign_values}
2148           ? "'foreign_values'-based reversed-"
2149           : ''
2150     );
2151   }
2152
2153   # we got something back - sanity check and infer values if we can
2154   my @nonvalues;
2155   if (
2156     $ret->{join_free_condition}
2157       and
2158     $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION
2159       and
2160     my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} )
2161   ) {
2162
2163     my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls');
2164
2165     if (keys %$jfc_eqs) {
2166
2167       for (keys %$jfc) {
2168         # $jfc is fully qualified by definition
2169         my ($col) = $_ =~ /\.(.+)/;
2170
2171         if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) {
2172           $ret->{inferred_values}{$col} = $jfc_eqs->{$_};
2173         }
2174         elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) {
2175           push @nonvalues, $col;
2176         }
2177       }
2178
2179       # all or nothing
2180       delete $ret->{inferred_values} if @nonvalues;
2181     }
2182   }
2183
2184   # did the user explicitly ask
2185   if ($args->{infer_values_based_on}) {
2186
2187     $self->throw_exception(sprintf (
2188       "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s",
2189       map { "'$_'" } @nonvalues
2190     )) if @nonvalues;
2191
2192
2193     $ret->{inferred_values} ||= {};
2194
2195     $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_}
2196       for keys %{$args->{infer_values_based_on}};
2197   }
2198
2199   # add the identities based on the main condition
2200   # (may already be there, since easy to calculate on the fly in the HASH case)
2201   if ( ! $ret->{identity_map} ) {
2202
2203     my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition});
2204
2205     my $colinfos;
2206     for my $lhs (keys %$col_eqs) {
2207
2208       next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION;
2209
2210       # there is no way to know who is right and who is left in a cref
2211       # therefore a full blown resolution call, and figure out the
2212       # direction a bit further below
2213       $colinfos ||= $storage->_resolve_column_info([
2214         { -alias => $args->{self_alias}, -rsrc => $self },
2215         { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc },
2216       ]);
2217
2218       next unless $colinfos->{$lhs};  # someone is engaging in witchcraft
2219
2220       if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) {
2221
2222         if (
2223           $colinfos->{$rhs_ref->[0]}
2224             and
2225           $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias}
2226         ) {
2227           ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} )
2228             ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} )
2229             : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} )
2230           ;
2231         }
2232       }
2233       elsif (
2234         $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x
2235           and
2236         ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc
2237       ) {
2238         my ($lcol, $rcol) = map
2239           { $colinfos->{$_}{-colname} }
2240           ( $lhs, $1 )
2241         ;
2242         carp_unique(
2243           "The $exception_rel_id specifies equality of column '$lcol' and the "
2244         . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)"
2245         );
2246       }
2247     }
2248   }
2249
2250   # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition
2251   $ret->{condition} = { -and => [ $ret->{condition} ] }
2252     unless $ret->{condition} eq UNRESOLVABLE_CONDITION;
2253
2254   $ret;
2255 }
2256
2257 =head2 related_source
2258
2259 =over 4
2260
2261 =item Arguments: $rel_name
2262
2263 =item Return Value: $source
2264
2265 =back
2266
2267 Returns the result source object for the given relationship.
2268
2269 =cut
2270
2271 sub related_source {
2272   my ($self, $rel) = @_;
2273   if( !$self->has_relationship( $rel ) ) {
2274     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2275   }
2276
2277   # if we are not registered with a schema - just use the prototype
2278   # however if we do have a schema - ask for the source by name (and
2279   # throw in the process if all fails)
2280   if (my $schema = dbic_internal_try { $self->schema }) {
2281     $schema->source($self->relationship_info($rel)->{source});
2282   }
2283   else {
2284     my $class = $self->relationship_info($rel)->{class};
2285     $self->ensure_class_loaded($class);
2286     $class->result_source_instance;
2287   }
2288 }
2289
2290 =head2 related_class
2291
2292 =over 4
2293
2294 =item Arguments: $rel_name
2295
2296 =item Return Value: $classname
2297
2298 =back
2299
2300 Returns the class name for objects in the given relationship.
2301
2302 =cut
2303
2304 sub related_class {
2305   my ($self, $rel) = @_;
2306   if( !$self->has_relationship( $rel ) ) {
2307     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2308   }
2309   return $self->schema->class($self->relationship_info($rel)->{source});
2310 }
2311
2312 =head2 handle
2313
2314 =over 4
2315
2316 =item Arguments: none
2317
2318 =item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle>
2319
2320 =back
2321
2322 Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
2323 for this source. Used as a serializable pointer to this resultsource, as it is not
2324 easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
2325 relationship definitions.
2326
2327 =cut
2328
2329 sub handle {
2330   require DBIx::Class::ResultSourceHandle;
2331   return DBIx::Class::ResultSourceHandle->new({
2332     source_moniker => $_[0]->source_name,
2333
2334     # so that a detached thaw can be re-frozen
2335     $_[0]->{_detached_thaw}
2336       ? ( _detached_source  => $_[0]          )
2337       : ( schema            => $_[0]->schema  )
2338     ,
2339   });
2340 }
2341
2342 my $global_phase_destroy;
2343 sub DESTROY {
2344   ### NO detected_reinvoked_destructor check
2345   ### This code very much relies on being called multuple times
2346
2347   return if $global_phase_destroy ||= in_global_destruction;
2348
2349 ######
2350 # !!! ACHTUNG !!!!
2351 ######
2352 #
2353 # Under no circumstances shall $_[0] be stored anywhere else (like copied to
2354 # a lexical variable, or shifted, or anything else). Doing so will mess up
2355 # the refcount of this particular result source, and will allow the $schema
2356 # we are trying to save to reattach back to the source we are destroying.
2357 # The relevant code checking refcounts is in ::Schema::DESTROY()
2358
2359   # if we are not a schema instance holder - we don't matter
2360   return if(
2361     ! ref $_[0]->{schema}
2362       or
2363     isweak $_[0]->{schema}
2364   );
2365
2366   # weaken our schema hold forcing the schema to find somewhere else to live
2367   # during global destruction (if we have not yet bailed out) this will throw
2368   # which will serve as a signal to not try doing anything else
2369   # however beware - on older perls the exception seems randomly untrappable
2370   # due to some weird race condition during thread joining :(((
2371   local $SIG{__DIE__} if $SIG{__DIE__};
2372   local $@;
2373   eval {
2374     weaken $_[0]->{schema};
2375
2376     # if schema is still there reintroduce ourselves with strong refs back to us
2377     if ($_[0]->{schema}) {
2378       my $srcregs = $_[0]->{schema}->source_registrations;
2379
2380       defined $srcregs->{$_}
2381         and
2382       $srcregs->{$_} == $_[0]
2383         and
2384       $srcregs->{$_} = $_[0]
2385         and
2386       last
2387         for keys %$srcregs;
2388     }
2389
2390     1;
2391   } or do {
2392     $global_phase_destroy = 1;
2393   };
2394
2395   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
2396   # collected before leaving this scope. Depending on the code above, this
2397   # may very well be just a preventive measure guarding future modifications
2398   undef;
2399 }
2400
2401 sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
2402
2403 sub STORABLE_thaw {
2404   my ($self, $cloning, $ice) = @_;
2405   %$self = %{ (Storable::thaw($ice))->resolve };
2406 }
2407
2408 =head2 throw_exception
2409
2410 See L<DBIx::Class::Schema/"throw_exception">.
2411
2412 =cut
2413
2414 sub throw_exception {
2415   my $self = shift;
2416
2417   $self->{schema}
2418     ? $self->{schema}->throw_exception(@_)
2419     : DBIx::Class::Exception->throw(@_)
2420   ;
2421 }
2422
2423 =head2 column_info_from_storage
2424
2425 =over
2426
2427 =item Arguments: 1/0 (default: 0)
2428
2429 =item Return Value: 1/0
2430
2431 =back
2432
2433   __PACKAGE__->column_info_from_storage(1);
2434
2435 Enables the on-demand automatic loading of the above column
2436 metadata from storage as necessary.  This is *deprecated*, and
2437 should not be used.  It will be removed before 1.0.
2438
2439 =head1 FURTHER QUESTIONS?
2440
2441 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
2442
2443 =head1 COPYRIGHT AND LICENSE
2444
2445 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
2446 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
2447 redistribute it and/or modify it under the same terms as the
2448 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
2449
2450 =cut
2451
2452 1;