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