Add an explicit Sub::Quote dep in ::_Util
[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   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
808
809   my $self = shift;
810   my @constraints = @_;
811
812   if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) {
813     # with constraint name
814     while (my ($name, $constraint) = splice @constraints, 0, 2) {
815       $self->add_unique_constraint($name => $constraint);
816     }
817   }
818   else {
819     # no constraint name
820     foreach my $constraint (@constraints) {
821       $self->add_unique_constraint($constraint);
822     }
823   }
824 }
825
826 =head2 name_unique_constraint
827
828 =over 4
829
830 =item Arguments: \@colnames
831
832 =item Return Value: Constraint name
833
834 =back
835
836   $source->table('mytable');
837   $source->name_unique_constraint(['col1', 'col2']);
838   # returns
839   'mytable_col1_col2'
840
841 Return a name for a unique constraint containing the specified
842 columns. The name is created by joining the table name and each column
843 name, using an underscore character.
844
845 For example, a constraint on a table named C<cd> containing the columns
846 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
847
848 This is used by L</add_unique_constraint> if you do not specify the
849 optional constraint name.
850
851 =cut
852
853 sub name_unique_constraint {
854   my ($self, $cols) = @_;
855
856   my $name = $self->name;
857   $name = $$name if (ref $name eq 'SCALAR');
858   $name =~ s/ ^ [^\.]+ \. //x;  # strip possible schema qualifier
859
860   return join '_', $name, @$cols;
861 }
862
863 =head2 unique_constraints
864
865 =over 4
866
867 =item Arguments: none
868
869 =item Return Value: Hash of unique constraint data
870
871 =back
872
873   $source->unique_constraints();
874
875 Read-only accessor which returns a hash of unique constraints on this
876 source.
877
878 The hash is keyed by constraint name, and contains an arrayref of
879 column names as values.
880
881 =cut
882
883 sub unique_constraints {
884   return %{shift->_unique_constraints||{}};
885 }
886
887 =head2 unique_constraint_names
888
889 =over 4
890
891 =item Arguments: none
892
893 =item Return Value: Unique constraint names
894
895 =back
896
897   $source->unique_constraint_names();
898
899 Returns the list of unique constraint names defined on this source.
900
901 =cut
902
903 sub unique_constraint_names {
904   my ($self) = @_;
905
906   my %unique_constraints = $self->unique_constraints;
907
908   return keys %unique_constraints;
909 }
910
911 =head2 unique_constraint_columns
912
913 =over 4
914
915 =item Arguments: $constraintname
916
917 =item Return Value: List of constraint columns
918
919 =back
920
921   $source->unique_constraint_columns('myconstraint');
922
923 Returns the list of columns that make up the specified unique constraint.
924
925 =cut
926
927 sub unique_constraint_columns {
928   my ($self, $constraint_name) = @_;
929
930   my %unique_constraints = $self->unique_constraints;
931
932   $self->throw_exception(
933     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
934   ) unless exists $unique_constraints{$constraint_name};
935
936   return @{ $unique_constraints{$constraint_name} };
937 }
938
939 =head2 sqlt_deploy_callback
940
941 =over
942
943 =item Arguments: $callback_name | \&callback_code
944
945 =item Return Value: $callback_name | \&callback_code
946
947 =back
948
949   __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod');
950
951    or
952
953   __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub {
954     my ($source_instance, $sqlt_table) = @_;
955     ...
956   } );
957
958 An accessor to set a callback to be called during deployment of
959 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
960 L<DBIx::Class::Schema/deploy>.
961
962 The callback can be set as either a code reference or the name of a
963 method in the current result class.
964
965 Defaults to L</default_sqlt_deploy_hook>.
966
967 Your callback will be passed the $source object representing the
968 ResultSource instance being deployed, and the
969 L<SQL::Translator::Schema::Table> object being created from it. The
970 callback can be used to manipulate the table object or add your own
971 customised indexes. If you need to manipulate a non-table object, use
972 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
973
974 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
975 Your SQL> for examples.
976
977 This sqlt deployment callback can only be used to manipulate
978 SQL::Translator objects as they get turned into SQL. To execute
979 post-deploy statements which SQL::Translator does not currently
980 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
981 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
982
983 =head2 default_sqlt_deploy_hook
984
985 This is the default deploy hook implementation which checks if your
986 current Result class has a C<sqlt_deploy_hook> method, and if present
987 invokes it B<on the Result class directly>. This is to preserve the
988 semantics of C<sqlt_deploy_hook> which was originally designed to expect
989 the Result class name and the
990 L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being
991 deployed.
992
993 =cut
994
995 sub default_sqlt_deploy_hook {
996   my $self = shift;
997
998   my $class = $self->result_class;
999
1000   if ($class and $class->can('sqlt_deploy_hook')) {
1001     $class->sqlt_deploy_hook(@_);
1002   }
1003 }
1004
1005 sub _invoke_sqlt_deploy_hook {
1006   my $self = shift;
1007   if ( my $hook = $self->sqlt_deploy_callback) {
1008     $self->$hook(@_);
1009   }
1010 }
1011
1012 =head2 result_class
1013
1014 =over 4
1015
1016 =item Arguments: $classname
1017
1018 =item Return Value: $classname
1019
1020 =back
1021
1022  use My::Schema::ResultClass::Inflator;
1023  ...
1024
1025  use My::Schema::Artist;
1026  ...
1027  __PACKAGE__->result_class('My::Schema::ResultClass::Inflator');
1028
1029 Set the default result class for this source. You can use this to create
1030 and use your own result inflator. See L<DBIx::Class::ResultSet/result_class>
1031 for more details.
1032
1033 Please note that setting this to something like
1034 L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed
1035 and make life more difficult.  Inflators like those are better suited to
1036 temporary usage via L<DBIx::Class::ResultSet/result_class>.
1037
1038 =head2 resultset
1039
1040 =over 4
1041
1042 =item Arguments: none
1043
1044 =item Return Value: L<$resultset|DBIx::Class::ResultSet>
1045
1046 =back
1047
1048 Returns a resultset for the given source. This will initially be created
1049 on demand by calling
1050
1051   $self->resultset_class->new($self, $self->resultset_attributes)
1052
1053 but is cached from then on unless resultset_class changes.
1054
1055 =head2 resultset_class
1056
1057 =over 4
1058
1059 =item Arguments: $classname
1060
1061 =item Return Value: $classname
1062
1063 =back
1064
1065   package My::Schema::ResultSet::Artist;
1066   use base 'DBIx::Class::ResultSet';
1067   ...
1068
1069   # In the result class
1070   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
1071
1072   # Or in code
1073   $source->resultset_class('My::Schema::ResultSet::Artist');
1074
1075 Set the class of the resultset. This is useful if you want to create your
1076 own resultset methods. Create your own class derived from
1077 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1078 this method returns the name of the existing resultset class, if one
1079 exists.
1080
1081 =head2 resultset_attributes
1082
1083 =over 4
1084
1085 =item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1086
1087 =item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1088
1089 =back
1090
1091   # In the result class
1092   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
1093
1094   # Or in code
1095   $source->resultset_attributes({ order_by => [ 'id' ] });
1096
1097 Store a collection of resultset attributes, that will be set on every
1098 L<DBIx::Class::ResultSet> produced from this result source.
1099
1100 B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and
1101 bugs! Notably the contents of the attributes are B<entirely static>, which
1102 greatly hinders composability (things like L<current_source_alias
1103 |DBIx::Class::ResultSet/current_source_alias> can not possibly be respected).
1104 While C<resultset_attributes> isn't deprecated per se, you are strongly urged
1105 to seek alternatives.
1106
1107 Since relationships use attributes to link tables together, the "default"
1108 attributes you set may cause unpredictable and undesired behavior.  Furthermore,
1109 the defaults B<cannot be turned off>, so you are stuck with them.
1110
1111 In most cases, what you should actually be using are project-specific methods:
1112
1113   package My::Schema::ResultSet::Artist;
1114   use base 'DBIx::Class::ResultSet';
1115   ...
1116
1117   # BAD IDEA!
1118   #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' });
1119
1120   # GOOD IDEA!
1121   sub with_tracks { shift->search({}, { prefetch => 'tracks' }) }
1122
1123   # in your code
1124   $schema->resultset('Artist')->with_tracks->...
1125
1126 This gives you the flexibility of not using it when you don't need it.
1127
1128 For more complex situations, another solution would be to use a virtual view
1129 via L<DBIx::Class::ResultSource::View>.
1130
1131 =cut
1132
1133 sub resultset {
1134   my $self = shift;
1135   $self->throw_exception(
1136     'resultset does not take any arguments. If you want another resultset, '.
1137     'call it on the schema instead.'
1138   ) if scalar @_;
1139
1140   $self->resultset_class->new(
1141     $self,
1142     {
1143       ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ),
1144       %{$self->{resultset_attributes}},
1145     },
1146   );
1147 }
1148
1149 =head2 name
1150
1151 =over 4
1152
1153 =item Arguments: none
1154
1155 =item Result value: $name
1156
1157 =back
1158
1159 Returns the name of the result source, which will typically be the table
1160 name. This may be a scalar reference if the result source has a non-standard
1161 name.
1162
1163 =head2 source_name
1164
1165 =over 4
1166
1167 =item Arguments: $source_name
1168
1169 =item Result value: $source_name
1170
1171 =back
1172
1173 Set an alternate name for the result source when it is loaded into a schema.
1174 This is useful if you want to refer to a result source by a name other than
1175 its class name.
1176
1177   package ArchivedBooks;
1178   use base qw/DBIx::Class/;
1179   __PACKAGE__->table('books_archive');
1180   __PACKAGE__->source_name('Books');
1181
1182   # from your schema...
1183   $schema->resultset('Books')->find(1);
1184
1185 =head2 from
1186
1187 =over 4
1188
1189 =item Arguments: none
1190
1191 =item Return Value: FROM clause
1192
1193 =back
1194
1195   my $from_clause = $source->from();
1196
1197 Returns an expression of the source to be supplied to storage to specify
1198 retrieval from this source. In the case of a database, the required FROM
1199 clause contents.
1200
1201 =cut
1202
1203 sub from { die 'Virtual method!' }
1204
1205 =head2 source_info
1206
1207 Stores a hashref of per-source metadata.  No specific key names
1208 have yet been standardized, the examples below are purely hypothetical
1209 and don't actually accomplish anything on their own:
1210
1211   __PACKAGE__->source_info({
1212     "_tablespace" => 'fast_disk_array_3',
1213     "_engine" => 'InnoDB',
1214   });
1215
1216 =head2 schema
1217
1218 =over 4
1219
1220 =item Arguments: L<$schema?|DBIx::Class::Schema>
1221
1222 =item Return Value: L<$schema|DBIx::Class::Schema>
1223
1224 =back
1225
1226   my $schema = $source->schema();
1227
1228 Sets and/or returns the L<DBIx::Class::Schema> object to which this
1229 result source instance has been attached to.
1230
1231 =cut
1232
1233 sub schema {
1234   if (@_ > 1) {
1235     $_[0]->{schema} = $_[1];
1236   }
1237   else {
1238     $_[0]->{schema} || do {
1239       my $name = $_[0]->{source_name} || '_unnamed_';
1240       my $err = 'Unable to perform storage-dependent operations with a detached result source '
1241               . "(source '$name' is not associated with a schema).";
1242
1243       $err .= ' You need to use $schema->thaw() or manually set'
1244             . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
1245         if $_[0]->{_detached_thaw};
1246
1247       DBIx::Class::Exception->throw($err);
1248     };
1249   }
1250 }
1251
1252 =head2 storage
1253
1254 =over 4
1255
1256 =item Arguments: none
1257
1258 =item Return Value: L<$storage|DBIx::Class::Storage>
1259
1260 =back
1261
1262   $source->storage->debug(1);
1263
1264 Returns the L<storage handle|DBIx::Class::Storage> for the current schema.
1265
1266 =cut
1267
1268 sub storage {
1269   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
1270   $_[0]->schema->storage
1271 }
1272
1273 =head2 add_relationship
1274
1275 =over 4
1276
1277 =item Arguments: $rel_name, $related_source_name, \%cond, \%attrs?
1278
1279 =item Return Value: 1/true if it succeeded
1280
1281 =back
1282
1283   $source->add_relationship('rel_name', 'related_source', $cond, $attrs);
1284
1285 L<DBIx::Class::Relationship> describes a series of methods which
1286 create pre-defined useful types of relationships. Look there first
1287 before using this method directly.
1288
1289 The relationship name can be arbitrary, but must be unique for each
1290 relationship attached to this result source. 'related_source' should
1291 be the name with which the related result source was registered with
1292 the current schema. For example:
1293
1294   $schema->source('Book')->add_relationship('reviews', 'Review', {
1295     'foreign.book_id' => 'self.id',
1296   });
1297
1298 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1299 representation of the join between the tables. For example, if you're
1300 creating a relation from Author to Book,
1301
1302   { 'foreign.author_id' => 'self.id' }
1303
1304 will result in the JOIN clause
1305
1306   author me JOIN book foreign ON foreign.author_id = me.id
1307
1308 You can specify as many foreign => self mappings as necessary.
1309
1310 Valid attributes are as follows:
1311
1312 =over 4
1313
1314 =item join_type
1315
1316 Explicitly specifies the type of join to use in the relationship. Any
1317 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1318 the SQL command immediately before C<JOIN>.
1319
1320 =item proxy
1321
1322 An arrayref containing a list of accessors in the foreign class to proxy in
1323 the main class. If, for example, you do the following:
1324
1325   CD->might_have(liner_notes => 'LinerNotes', undef, {
1326     proxy => [ qw/notes/ ],
1327   });
1328
1329 Then, assuming LinerNotes has an accessor named notes, you can do:
1330
1331   my $cd = CD->find(1);
1332   # set notes -- LinerNotes object is created if it doesn't exist
1333   $cd->notes('Notes go here');
1334
1335 =item accessor
1336
1337 Specifies the type of accessor that should be created for the
1338 relationship. Valid values are C<single> (for when there is only a single
1339 related object), C<multi> (when there can be many), and C<filter> (for
1340 when there is a single related object, but you also want the relationship
1341 accessor to double as a column accessor). For C<multi> accessors, an
1342 add_to_* method is also created, which calls C<create_related> for the
1343 relationship.
1344
1345 =back
1346
1347 Throws an exception if the condition is improperly supplied, or cannot
1348 be resolved.
1349
1350 =cut
1351
1352 sub add_relationship {
1353   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1354   $self->throw_exception("Can't create relationship without join condition")
1355     unless $cond;
1356   $attrs ||= {};
1357
1358   # Check foreign and self are right in cond
1359   if ( (ref $cond ||'') eq 'HASH') {
1360     $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'")
1361       for keys %$cond;
1362
1363     $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'")
1364       for values %$cond;
1365   }
1366
1367   my %rels = %{ $self->_relationships };
1368   $rels{$rel} = { class => $f_source_name,
1369                   source => $f_source_name,
1370                   cond  => $cond,
1371                   attrs => $attrs };
1372   $self->_relationships(\%rels);
1373
1374   return $self;
1375 }
1376
1377 =head2 relationships
1378
1379 =over 4
1380
1381 =item Arguments: none
1382
1383 =item Return Value: L<@rel_names|DBIx::Class::Relationship>
1384
1385 =back
1386
1387   my @rel_names = $source->relationships();
1388
1389 Returns all relationship names for this source.
1390
1391 =cut
1392
1393 sub relationships {
1394   keys %{$_[0]->_relationships};
1395 }
1396
1397 =head2 relationship_info
1398
1399 =over 4
1400
1401 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1402
1403 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1404
1405 =back
1406
1407 Returns a hash of relationship information for the specified relationship
1408 name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>.
1409
1410 =cut
1411
1412 sub relationship_info {
1413   #my ($self, $rel) = @_;
1414   return shift->_relationships->{+shift};
1415 }
1416
1417 =head2 has_relationship
1418
1419 =over 4
1420
1421 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1422
1423 =item Return Value: 1/0 (true/false)
1424
1425 =back
1426
1427 Returns true if the source has a relationship of this name, false otherwise.
1428
1429 =cut
1430
1431 sub has_relationship {
1432   #my ($self, $rel) = @_;
1433   return exists shift->_relationships->{+shift};
1434 }
1435
1436 =head2 reverse_relationship_info
1437
1438 =over 4
1439
1440 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1441
1442 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1443
1444 =back
1445
1446 Looks through all the relationships on the source this relationship
1447 points to, looking for one whose condition is the reverse of the
1448 condition on this relationship.
1449
1450 A common use of this is to find the name of the C<belongs_to> relation
1451 opposing a C<has_many> relation. For definition of these look in
1452 L<DBIx::Class::Relationship>.
1453
1454 The returned hashref is keyed by the name of the opposing
1455 relationship, and contains its data in the same manner as
1456 L</relationship_info>.
1457
1458 =cut
1459
1460 sub reverse_relationship_info {
1461   my ($self, $rel) = @_;
1462
1463   my $rel_info = $self->relationship_info($rel)
1464     or $self->throw_exception("No such relationship '$rel'");
1465
1466   my $ret = {};
1467
1468   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1469
1470   my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
1471
1472   my $registered_source_name = $self->source_name;
1473
1474   # this may be a partial schema or something else equally esoteric
1475   my $other_rsrc = $self->related_source($rel);
1476
1477   # Get all the relationships for that source that related to this source
1478   # whose foreign column set are our self columns on $rel and whose self
1479   # columns are our foreign columns on $rel
1480   foreach my $other_rel ($other_rsrc->relationships) {
1481
1482     # only consider stuff that points back to us
1483     # "us" here is tricky - if we are in a schema registration, we want
1484     # to use the source_names, otherwise we will use the actual classes
1485
1486     # the schema may be partial
1487     my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
1488       or next;
1489
1490     if ($registered_source_name) {
1491       next if $registered_source_name ne ($roundtrip_rsrc->source_name || '')
1492     }
1493     else {
1494       next if $self->result_class ne $roundtrip_rsrc->result_class;
1495     }
1496
1497     my $other_rel_info = $other_rsrc->relationship_info($other_rel);
1498
1499     # this can happen when we have a self-referential class
1500     next if $other_rel_info eq $rel_info;
1501
1502     next unless ref $other_rel_info->{cond} eq 'HASH';
1503     my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
1504
1505     $ret->{$other_rel} = $other_rel_info if (
1506       $self->_compare_relationship_keys (
1507         [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
1508       )
1509         and
1510       $self->_compare_relationship_keys (
1511         [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
1512       )
1513     );
1514   }
1515
1516   return $ret;
1517 }
1518
1519 # all this does is removes the foreign/self prefix from a condition
1520 sub __strip_relcond {
1521   +{
1522     map
1523       { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
1524       keys %{$_[1]}
1525   }
1526 }
1527
1528 sub compare_relationship_keys {
1529   carp 'compare_relationship_keys is a private method, stop calling it';
1530   my $self = shift;
1531   $self->_compare_relationship_keys (@_);
1532 }
1533
1534 # Returns true if both sets of keynames are the same, false otherwise.
1535 sub _compare_relationship_keys {
1536 #  my ($self, $keys1, $keys2) = @_;
1537   return
1538     join ("\x00", sort @{$_[1]})
1539       eq
1540     join ("\x00", sort @{$_[2]})
1541   ;
1542 }
1543
1544 # optionally takes either an arrayref of column names, or a hashref of already
1545 # retrieved colinfos
1546 # returns an arrayref of column names of the shortest unique constraint
1547 # (matching some of the input if any), giving preference to the PK
1548 sub _identifying_column_set {
1549   my ($self, $cols) = @_;
1550
1551   my %unique = $self->unique_constraints;
1552   my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||());
1553
1554   # always prefer the PK first, and then shortest constraints first
1555   USET:
1556   for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) {
1557     next unless $set && @$set;
1558
1559     for (@$set) {
1560       next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} );
1561     }
1562
1563     # copy so we can mangle it at will
1564     return [ @$set ];
1565   }
1566
1567   return undef;
1568 }
1569
1570 sub _minimal_valueset_satisfying_constraint {
1571   my $self = shift;
1572   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1573
1574   $args->{columns_info} ||= $self->columns_info;
1575
1576   my $vals = $self->schema->storage->_extract_fixed_condition_columns(
1577     $args->{values},
1578     ($args->{carp_on_nulls} ? 'consider_nulls' : undef ),
1579   );
1580
1581   my $cols;
1582   for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) {
1583     if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) {
1584       $cols->{missing}{$col} = undef;
1585     }
1586     elsif( ! defined $vals->{$col} ) {
1587       $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef;
1588     }
1589     else {
1590       # we need to inject back the '=' as _extract_fixed_condition_columns
1591       # will strip it from literals and values alike, resulting in an invalid
1592       # condition in the end
1593       $cols->{present}{$col} = { '=' => $vals->{$col} };
1594     }
1595
1596     $cols->{fc}{$col} = 1 if (
1597       ( ! $cols->{missing} or ! exists $cols->{missing}{$col} )
1598         and
1599       keys %{ $args->{columns_info}{$col}{_filter_info} || {} }
1600     );
1601   }
1602
1603   $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s",
1604     $args->{constraint_name},
1605     join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ),
1606   ) ) if $cols->{missing};
1607
1608   $self->throw_exception( sprintf (
1609     "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s",
1610     $args->{constraint_name},
1611     join (', ', map { "'$_'" } sort keys %{$cols->{fc}}),
1612   )) if $cols->{fc};
1613
1614   if (
1615     $cols->{undefined}
1616       and
1617     !$ENV{DBIC_NULLABLE_KEY_NOWARN}
1618   ) {
1619     carp_unique ( sprintf (
1620       "NULL/undef values supplied for requested unique constraint '%s' (NULL "
1621     . 'values in column(s): %s). This is almost certainly not what you wanted, '
1622     . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
1623       $args->{constraint_name},
1624       join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}),
1625     ));
1626   }
1627
1628   return { map { %{ $cols->{$_}||{} } } qw(present undefined) };
1629 }
1630
1631 # Returns the {from} structure used to express JOIN conditions
1632 sub _resolve_join {
1633   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1634
1635   # we need a supplied one, because we do in-place modifications, no returns
1636   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1637     unless ref $seen eq 'HASH';
1638
1639   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1640     unless ref $jpath eq 'ARRAY';
1641
1642   $jpath = [@$jpath]; # copy
1643
1644   if (not defined $join or not length $join) {
1645     return ();
1646   }
1647   elsif (ref $join eq 'ARRAY') {
1648     return
1649       map {
1650         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1651       } @$join;
1652   }
1653   elsif (ref $join eq 'HASH') {
1654
1655     my @ret;
1656     for my $rel (keys %$join) {
1657
1658       my $rel_info = $self->relationship_info($rel)
1659         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1660
1661       my $force_left = $parent_force_left;
1662       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1663
1664       # the actual seen value will be incremented by the recursion
1665       my $as = $self->schema->storage->relname_to_table_alias(
1666         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1667       );
1668
1669       push @ret, (
1670         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1671         $self->related_source($rel)->_resolve_join(
1672           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1673         )
1674       );
1675     }
1676     return @ret;
1677
1678   }
1679   elsif (ref $join) {
1680     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1681   }
1682   else {
1683     my $count = ++$seen->{$join};
1684     my $as = $self->schema->storage->relname_to_table_alias(
1685       $join, ($count > 1 && $count)
1686     );
1687
1688     my $rel_info = $self->relationship_info($join)
1689       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1690
1691     my $rel_src = $self->related_source($join);
1692     return [ { $as => $rel_src->from,
1693                -rsrc => $rel_src,
1694                -join_type => $parent_force_left
1695                   ? 'left'
1696                   : $rel_info->{attrs}{join_type}
1697                 ,
1698                -join_path => [@$jpath, { $join => $as } ],
1699                -is_single => (
1700                   ! $rel_info->{attrs}{accessor}
1701                     or
1702                   $rel_info->{attrs}{accessor} eq 'single'
1703                     or
1704                   $rel_info->{attrs}{accessor} eq 'filter'
1705                 ),
1706                -alias => $as,
1707                -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1,
1708              },
1709              $self->_resolve_relationship_condition(
1710                rel_name => $join,
1711                self_alias => $alias,
1712                foreign_alias => $as,
1713              )->{condition},
1714           ];
1715   }
1716 }
1717
1718 sub pk_depends_on {
1719   carp 'pk_depends_on is a private method, stop calling it';
1720   my $self = shift;
1721   $self->_pk_depends_on (@_);
1722 }
1723
1724 # Determines whether a relation is dependent on an object from this source
1725 # having already been inserted. Takes the name of the relationship and a
1726 # hashref of columns of the related object.
1727 sub _pk_depends_on {
1728   my ($self, $rel_name, $rel_data) = @_;
1729
1730   my $relinfo = $self->relationship_info($rel_name);
1731
1732   # don't assume things if the relationship direction is specified
1733   return $relinfo->{attrs}{is_foreign_key_constraint}
1734     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1735
1736   my $cond = $relinfo->{cond};
1737   return 0 unless ref($cond) eq 'HASH';
1738
1739   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1740   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1741
1742   # assume anything that references our PK probably is dependent on us
1743   # rather than vice versa, unless the far side is (a) defined or (b)
1744   # auto-increment
1745   my $rel_source = $self->related_source($rel_name);
1746
1747   foreach my $p ($self->primary_columns) {
1748     if (exists $keyhash->{$p}) {
1749       unless (defined($rel_data->{$keyhash->{$p}})
1750               || $rel_source->column_info($keyhash->{$p})
1751                             ->{is_auto_increment}) {
1752         return 0;
1753       }
1754     }
1755   }
1756
1757   return 1;
1758 }
1759
1760 sub resolve_condition {
1761   carp 'resolve_condition is a private method, stop calling it';
1762   shift->_resolve_condition (@_);
1763 }
1764
1765 sub _resolve_condition {
1766 #  carp_unique sprintf
1767 #    '_resolve_condition is a private method, and moreover is about to go '
1768 #  . 'away. Please contact the development team at %s if you believe you '
1769 #  . 'have a genuine use for this method, in order to discuss alternatives.',
1770 #    DBIx::Class::_ENV_::HELP_URL,
1771 #  ;
1772
1773 #######################
1774 ### API Design? What's that...? (a backwards compatible shim, kill me now)
1775
1776   my ($self, $cond, @res_args, $rel_name);
1777
1778   # we *SIMPLY DON'T KNOW YET* which arg is which, yay
1779   ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_;
1780
1781   # assume that an undef is an object-like unset (set_from_related(undef))
1782   my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args);
1783
1784   # turn objlike into proper objects for saner code further down
1785   for (0,1) {
1786     next unless $is_objlike[$_];
1787
1788     if ( defined blessed $res_args[$_] ) {
1789
1790       # but wait - there is more!!! WHAT THE FUCK?!?!?!?!
1791       if ($res_args[$_]->isa('DBIx::Class::ResultSet')) {
1792         carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__');
1793         $is_objlike[$_] = 0;
1794         $res_args[$_] = '__gremlins__';
1795       }
1796     }
1797     else {
1798       $res_args[$_] ||= {};
1799
1800       # hate everywhere - have to pass in as a plain hash
1801       # pretending to be an object at least for now
1802       $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]")
1803         unless ref $res_args[$_] eq 'HASH';
1804     }
1805   }
1806
1807   my $args = {
1808     # where-is-waldo block guesses relname, then further down we override it if available
1809     (
1810       $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me',         self_result_object  => $res_args[1] )
1811     : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me',         foreign_alias => $res_args[1], foreign_values      => $res_args[0] )
1812     :                  ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0]                                      )
1813     ),
1814
1815     ( $rel_name ? ( rel_name => $rel_name ) : () ),
1816   };
1817
1818   # Allowing passing relconds different than the relationshup itself is cute,
1819   # but likely dangerous. Remove that from the (still unofficial) API of
1820   # _resolve_relationship_condition, and instead make it "hard on purpose"
1821   local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond;
1822
1823 #######################
1824
1825   # now it's fucking easy isn't it?!
1826   my $rc = $self->_resolve_relationship_condition( $args );
1827
1828   my @res = (
1829     ( $rc->{join_free_condition} || $rc->{condition} ),
1830     ! $rc->{join_free_condition},
1831   );
1832
1833   # _resolve_relationship_condition always returns qualified cols even in the
1834   # case of join_free_condition, but nothing downstream expects this
1835   if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') {
1836     $res[0] = { map
1837       { ($_ =~ /\.(.+)/) => $res[0]{$_} }
1838       keys %{$res[0]}
1839     };
1840   }
1841
1842   # and more legacy
1843   return wantarray ? @res : $res[0];
1844 }
1845
1846 # Keep this indefinitely. There is evidence of both CPAN and
1847 # darkpan using it, and there isn't much harm in an extra var
1848 # anyway.
1849 our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION;
1850 # YES I KNOW THIS IS EVIL
1851 # it is there to save darkpan from themselves, since internally
1852 # we are moving to a constant
1853 Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1);
1854
1855 # Resolves the passed condition to a concrete query fragment and extra
1856 # metadata
1857 #
1858 ## self-explanatory API, modeled on the custom cond coderef:
1859 # rel_name              => (scalar)
1860 # foreign_alias         => (scalar)
1861 # foreign_values        => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef )
1862 # self_alias            => (scalar)
1863 # self_result_object    => (either not supplied or a result object)
1864 # require_join_free_condition => (boolean, throws on failure to construct a JF-cond)
1865 # infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition)
1866 #
1867 ## returns a hash
1868 # condition           => (a valid *likely fully qualified* sqla cond structure)
1869 # identity_map        => (a hashref of foreign-to-self *unqualified* column equality names)
1870 # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset)
1871 # inferred_values     => (in case of an available join_free condition, this is a hashref of
1872 #                         *unqualified* column/value *EQUALITY* pairs, representing an amalgamation
1873 #                         of the JF-cond parse and infer_values_based_on
1874 #                         always either complete or unset)
1875 #
1876 sub _resolve_relationship_condition {
1877   my $self = shift;
1878
1879   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1880
1881   for ( qw( rel_name self_alias foreign_alias ) ) {
1882     $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string")
1883       if !defined $args->{$_} or length ref $args->{$_};
1884   }
1885
1886   $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical")
1887     if $args->{self_alias} eq $args->{foreign_alias};
1888
1889 # TEMP
1890   my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'";
1891
1892   my $rel_info = $self->relationship_info($args->{rel_name})
1893 # TEMP
1894 #    or $self->throw_exception( "No such $exception_rel_id" );
1895     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");
1896
1897 # TEMP
1898   $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'"
1899     if $rel_info and exists $rel_info->{_original_name};
1900
1901   $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures")
1902     if exists $args->{self_result_object} and exists $args->{foreign_values};
1903
1904   $self->throw_exception( "Argument to infer_values_based_on must be a hash" )
1905     if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH';
1906
1907   $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on};
1908
1909   $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" )
1910     if (
1911       exists $args->{self_result_object}
1912         and
1913       ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') )
1914     )
1915   ;
1916
1917   my $rel_rsrc = $self->related_source($args->{rel_name});
1918   my $storage = $self->schema->storage;
1919
1920   if (exists $args->{foreign_values}) {
1921
1922     if (! defined $args->{foreign_values} ) {
1923       # fallback: undef => {}
1924       $args->{foreign_values} = {};
1925     }
1926     elsif (defined blessed $args->{foreign_values}) {
1927
1928       $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" )
1929         unless $args->{foreign_values}->isa('DBIx::Class::Row');
1930
1931       carp_unique(
1932         "Objects supplied as 'foreign_values' ($args->{foreign_values}) "
1933       . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), "
1934       . "perhaps you've made a mistake invoking the condition resolver?"
1935       ) unless $args->{foreign_values}->isa($rel_rsrc->result_class);
1936
1937       $args->{foreign_values} = { $args->{foreign_values}->get_columns };
1938     }
1939     elsif ( ref $args->{foreign_values} eq 'HASH' ) {
1940
1941       # re-build {foreign_values} excluding identically named rels
1942       if( keys %{$args->{foreign_values}} ) {
1943
1944         my ($col_idx, $rel_idx) = map
1945           { { map { $_ => 1 } $rel_rsrc->$_ } }
1946           qw( columns relationships )
1947         ;
1948
1949         my $equivalencies = $storage->_extract_fixed_condition_columns(
1950           $args->{foreign_values},
1951           'consider nulls',
1952         );
1953
1954         $args->{foreign_values} = { map {
1955           # skip if relationship *and* a non-literal ref
1956           # this means a multicreate stub was passed in
1957           (
1958             $rel_idx->{$_}
1959               and
1960             length ref $args->{foreign_values}{$_}
1961               and
1962             ! is_literal_value($args->{foreign_values}{$_})
1963           )
1964             ? ()
1965             : ( $_ => (
1966                 ! $col_idx->{$_}
1967                   ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" )
1968               : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION )
1969                   ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" )
1970               : $args->{foreign_values}{$_}
1971             ))
1972         } keys %{$args->{foreign_values}} };
1973       }
1974     }
1975     else {
1976       $self->throw_exception(
1977         "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', "
1978       . "or a hash reference, or undef"
1979       );
1980     }
1981   }
1982
1983   my $ret;
1984
1985   if (ref $rel_info->{cond} eq 'CODE') {
1986
1987     my $cref_args = {
1988       rel_name => $args->{rel_name},
1989       self_resultsource => $self,
1990       self_alias => $args->{self_alias},
1991       foreign_alias => $args->{foreign_alias},
1992       ( map
1993         { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () }
1994         qw( self_result_object foreign_values )
1995       ),
1996     };
1997
1998     # legacy - never remove these!!!
1999     $cref_args->{foreign_relname} = $cref_args->{rel_name};
2000
2001     $cref_args->{self_rowobj} = $cref_args->{self_result_object}
2002       if exists $cref_args->{self_result_object};
2003
2004     ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $rel_info->{cond}->($cref_args);
2005
2006     # sanity check
2007     $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra")
2008       if @extra;
2009
2010     if (my $jfc = $ret->{join_free_condition}) {
2011
2012       $self->throw_exception (
2013         "The join-free condition returned for $exception_rel_id must be a hash reference"
2014       ) unless ref $jfc eq 'HASH';
2015
2016       my ($joinfree_alias, $joinfree_source);
2017       if (defined $args->{self_result_object}) {
2018         $joinfree_alias = $args->{foreign_alias};
2019         $joinfree_source = $rel_rsrc;
2020       }
2021       elsif (defined $args->{foreign_values}) {
2022         $joinfree_alias = $args->{self_alias};
2023         $joinfree_source = $self;
2024       }
2025
2026       # FIXME sanity check until things stabilize, remove at some point
2027       $self->throw_exception (
2028         "A join-free condition returned for $exception_rel_id without a result object to chain from"
2029       ) unless $joinfree_alias;
2030
2031       my $fq_col_list = { map
2032         { ( "$joinfree_alias.$_" => 1 ) }
2033         $joinfree_source->columns
2034       };
2035
2036       exists $fq_col_list->{$_} or $self->throw_exception (
2037         "The join-free condition returned for $exception_rel_id may only "
2038       . 'contain keys that are fully qualified column names of the corresponding source '
2039       . "'$joinfree_alias' (instead it returned '$_')"
2040       ) for keys %$jfc;
2041
2042       (
2043         length ref $_
2044           and
2045         defined blessed($_)
2046           and
2047         $_->isa('DBIx::Class::Row')
2048           and
2049         $self->throw_exception (
2050           "The join-free condition returned for $exception_rel_id may not "
2051         . 'contain result objects as values - perhaps instead of invoking '
2052         . '->$something you meant to return ->get_column($something)'
2053         )
2054       ) for values %$jfc;
2055
2056     }
2057   }
2058   elsif (ref $rel_info->{cond} eq 'HASH') {
2059
2060     # the condition is static - use parallel arrays
2061     # for a "pivot" depending on which side of the
2062     # rel did we get as an object
2063     my (@f_cols, @l_cols);
2064     for my $fc (keys %{ $rel_info->{cond} }) {
2065       my $lc = $rel_info->{cond}{$fc};
2066
2067       # FIXME STRICTMODE should probably check these are valid columns
2068       $fc =~ s/^foreign\.// ||
2069         $self->throw_exception("Invalid rel cond key '$fc'");
2070
2071       $lc =~ s/^self\.// ||
2072         $self->throw_exception("Invalid rel cond val '$lc'");
2073
2074       push @f_cols, $fc;
2075       push @l_cols, $lc;
2076     }
2077
2078     # construct the crosstable condition and the identity map
2079     for  (0..$#f_cols) {
2080       $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" };
2081       $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_];
2082     };
2083
2084     if ($args->{foreign_values}) {
2085       $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]}
2086         for 0..$#f_cols;
2087     }
2088     elsif (defined $args->{self_result_object}) {
2089
2090       for my $i (0..$#l_cols) {
2091         if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) {
2092           $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]);
2093         }
2094         else {
2095           $self->throw_exception(sprintf
2096             "Unable to resolve relationship '%s' from object '%s': column '%s' not "
2097           . 'loaded from storage (or not passed to new() prior to insert()). You '
2098           . 'probably need to call ->discard_changes to get the server-side defaults '
2099           . 'from the database.',
2100             $args->{rel_name},
2101             $args->{self_result_object},
2102             $l_cols[$i],
2103           ) if $args->{self_result_object}->in_storage;
2104
2105           # FIXME - temporarly force-override
2106           delete $args->{require_join_free_condition};
2107           $ret->{join_free_condition} = UNRESOLVABLE_CONDITION;
2108           last;
2109         }
2110       }
2111     }
2112   }
2113   elsif (ref $rel_info->{cond} eq 'ARRAY') {
2114     if (@{ $rel_info->{cond} } == 0) {
2115       $ret = {
2116         condition => UNRESOLVABLE_CONDITION,
2117         join_free_condition => UNRESOLVABLE_CONDITION,
2118       };
2119     }
2120     else {
2121       my @subconds = map {
2122         local $rel_info->{cond} = $_;
2123         $self->_resolve_relationship_condition( $args );
2124       } @{ $rel_info->{cond} };
2125
2126       if( @{ $rel_info->{cond} } == 1 ) {
2127         $ret = $subconds[0];
2128       }
2129       else {
2130         # we are discarding inferred values here... likely incorrect...
2131         # then again - the entire thing is an OR, so we *can't* use them anyway
2132         for my $subcond ( @subconds ) {
2133           $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition')
2134             if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) );
2135
2136           $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition));
2137         }
2138       }
2139     }
2140   }
2141   else {
2142     $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :(");
2143   }
2144
2145   if (
2146     $args->{require_join_free_condition}
2147       and
2148     ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION )
2149   ) {
2150     $self->throw_exception(
2151       ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment",
2152         exists $args->{foreign_values}
2153           ? "'foreign_values'-based reversed-"
2154           : ''
2155     );
2156   }
2157
2158   # we got something back - sanity check and infer values if we can
2159   my @nonvalues;
2160   if (
2161     $ret->{join_free_condition}
2162       and
2163     $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION
2164       and
2165     my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} )
2166   ) {
2167
2168     my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls');
2169
2170     if (keys %$jfc_eqs) {
2171
2172       for (keys %$jfc) {
2173         # $jfc is fully qualified by definition
2174         my ($col) = $_ =~ /\.(.+)/;
2175
2176         if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) {
2177           $ret->{inferred_values}{$col} = $jfc_eqs->{$_};
2178         }
2179         elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) {
2180           push @nonvalues, $col;
2181         }
2182       }
2183
2184       # all or nothing
2185       delete $ret->{inferred_values} if @nonvalues;
2186     }
2187   }
2188
2189   # did the user explicitly ask
2190   if ($args->{infer_values_based_on}) {
2191
2192     $self->throw_exception(sprintf (
2193       "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s",
2194       map { "'$_'" } @nonvalues
2195     )) if @nonvalues;
2196
2197
2198     $ret->{inferred_values} ||= {};
2199
2200     $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_}
2201       for keys %{$args->{infer_values_based_on}};
2202   }
2203
2204   # add the identities based on the main condition
2205   # (may already be there, since easy to calculate on the fly in the HASH case)
2206   if ( ! $ret->{identity_map} ) {
2207
2208     my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition});
2209
2210     my $colinfos;
2211     for my $lhs (keys %$col_eqs) {
2212
2213       next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION;
2214
2215       # there is no way to know who is right and who is left in a cref
2216       # therefore a full blown resolution call, and figure out the
2217       # direction a bit further below
2218       $colinfos ||= $storage->_resolve_column_info([
2219         { -alias => $args->{self_alias}, -rsrc => $self },
2220         { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc },
2221       ]);
2222
2223       next unless $colinfos->{$lhs};  # someone is engaging in witchcraft
2224
2225       if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) {
2226
2227         if (
2228           $colinfos->{$rhs_ref->[0]}
2229             and
2230           $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias}
2231         ) {
2232           ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} )
2233             ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} )
2234             : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} )
2235           ;
2236         }
2237       }
2238       elsif (
2239         $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x
2240           and
2241         ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc
2242       ) {
2243         my ($lcol, $rcol) = map
2244           { $colinfos->{$_}{-colname} }
2245           ( $lhs, $1 )
2246         ;
2247         carp_unique(
2248           "The $exception_rel_id specifies equality of column '$lcol' and the "
2249         . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)"
2250         );
2251       }
2252     }
2253   }
2254
2255   # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition
2256   $ret->{condition} = { -and => [ $ret->{condition} ] }
2257     unless $ret->{condition} eq UNRESOLVABLE_CONDITION;
2258
2259   $ret;
2260 }
2261
2262 =head2 related_source
2263
2264 =over 4
2265
2266 =item Arguments: $rel_name
2267
2268 =item Return Value: $source
2269
2270 =back
2271
2272 Returns the result source object for the given relationship.
2273
2274 =cut
2275
2276 sub related_source {
2277   my ($self, $rel) = @_;
2278   if( !$self->has_relationship( $rel ) ) {
2279     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2280   }
2281
2282   # if we are not registered with a schema - just use the prototype
2283   # however if we do have a schema - ask for the source by name (and
2284   # throw in the process if all fails)
2285   if (my $schema = dbic_internal_try { $self->schema }) {
2286     $schema->source($self->relationship_info($rel)->{source});
2287   }
2288   else {
2289     my $class = $self->relationship_info($rel)->{class};
2290     $self->ensure_class_loaded($class);
2291     $class->result_source_instance;
2292   }
2293 }
2294
2295 =head2 related_class
2296
2297 =over 4
2298
2299 =item Arguments: $rel_name
2300
2301 =item Return Value: $classname
2302
2303 =back
2304
2305 Returns the class name for objects in the given relationship.
2306
2307 =cut
2308
2309 sub related_class {
2310   my ($self, $rel) = @_;
2311   if( !$self->has_relationship( $rel ) ) {
2312     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2313   }
2314   return $self->schema->class($self->relationship_info($rel)->{source});
2315 }
2316
2317 =head2 handle
2318
2319 =over 4
2320
2321 =item Arguments: none
2322
2323 =item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle>
2324
2325 =back
2326
2327 Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
2328 for this source. Used as a serializable pointer to this resultsource, as it is not
2329 easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
2330 relationship definitions.
2331
2332 =cut
2333
2334 sub handle {
2335   require DBIx::Class::ResultSourceHandle;
2336   return DBIx::Class::ResultSourceHandle->new({
2337     source_moniker => $_[0]->source_name,
2338
2339     # so that a detached thaw can be re-frozen
2340     $_[0]->{_detached_thaw}
2341       ? ( _detached_source  => $_[0]          )
2342       : ( schema            => $_[0]->schema  )
2343     ,
2344   });
2345 }
2346
2347 my $global_phase_destroy;
2348 sub DESTROY {
2349   ### NO detected_reinvoked_destructor check
2350   ### This code very much relies on being called multuple times
2351
2352   return if $global_phase_destroy ||= in_global_destruction;
2353
2354 ######
2355 # !!! ACHTUNG !!!!
2356 ######
2357 #
2358 # Under no circumstances shall $_[0] be stored anywhere else (like copied to
2359 # a lexical variable, or shifted, or anything else). Doing so will mess up
2360 # the refcount of this particular result source, and will allow the $schema
2361 # we are trying to save to reattach back to the source we are destroying.
2362 # The relevant code checking refcounts is in ::Schema::DESTROY()
2363
2364   # if we are not a schema instance holder - we don't matter
2365   return if(
2366     ! ref $_[0]->{schema}
2367       or
2368     isweak $_[0]->{schema}
2369   );
2370
2371   # weaken our schema hold forcing the schema to find somewhere else to live
2372   # during global destruction (if we have not yet bailed out) this will throw
2373   # which will serve as a signal to not try doing anything else
2374   # however beware - on older perls the exception seems randomly untrappable
2375   # due to some weird race condition during thread joining :(((
2376   local $SIG{__DIE__} if $SIG{__DIE__};
2377   local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
2378   eval {
2379     weaken $_[0]->{schema};
2380
2381     # if schema is still there reintroduce ourselves with strong refs back to us
2382     if ($_[0]->{schema}) {
2383       my $srcregs = $_[0]->{schema}->source_registrations;
2384
2385       defined $srcregs->{$_}
2386         and
2387       $srcregs->{$_} == $_[0]
2388         and
2389       $srcregs->{$_} = $_[0]
2390         and
2391       last
2392         for keys %$srcregs;
2393     }
2394
2395     1;
2396   } or do {
2397     $global_phase_destroy = 1;
2398   };
2399
2400   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
2401   # collected before leaving this scope. Depending on the code above, this
2402   # may very well be just a preventive measure guarding future modifications
2403   undef;
2404 }
2405
2406 sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
2407
2408 sub STORABLE_thaw {
2409   my ($self, $cloning, $ice) = @_;
2410   %$self = %{ (Storable::thaw($ice))->resolve };
2411 }
2412
2413 =head2 throw_exception
2414
2415 See L<DBIx::Class::Schema/"throw_exception">.
2416
2417 =cut
2418
2419 sub throw_exception {
2420   my $self = shift;
2421
2422   $self->{schema}
2423     ? $self->{schema}->throw_exception(@_)
2424     : DBIx::Class::Exception->throw(@_)
2425   ;
2426 }
2427
2428 =head2 column_info_from_storage
2429
2430 =over
2431
2432 =item Arguments: 1/0 (default: 0)
2433
2434 =item Return Value: 1/0
2435
2436 =back
2437
2438   __PACKAGE__->column_info_from_storage(1);
2439
2440 Enables the on-demand automatic loading of the above column
2441 metadata from storage as necessary.  This is *deprecated*, and
2442 should not be used.  It will be removed before 1.0.
2443
2444 =head1 FURTHER QUESTIONS?
2445
2446 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
2447
2448 =head1 COPYRIGHT AND LICENSE
2449
2450 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
2451 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
2452 redistribute it and/or modify it under the same terms as the
2453 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
2454
2455 =cut
2456
2457 1;