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