1package DBIx::Class::ResultSource;
2
3use strict;
4use warnings;
5
6use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/;
7
8use DBIx::Class::ResultSet;
9use DBIx::Class::ResultSourceHandle;
10
11use DBIx::Class::Carp;
12use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION';
13use SQL::Abstract::Util 'is_literal_value';
14use Devel::GlobalDestruction;
15use Try::Tiny;
16use Scalar::Util qw/blessed weaken isweak/;
17
18use 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
36DBIx::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
68A ResultSource is an object that represents a source of data for querying.
69
70This class is a base class for various specialised types of result
71sources, for example L<DBIx::Class::ResultSource::Table>. Table is the
72default result source type, so one is created for you when defining a
73result class as described in the synopsis above.
74
75More specifically, the L<DBIx::Class::Core> base class pulls in the
76L<DBIx::Class::ResultSourceProxy::Table> component, which defines
77the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
78When called, C<table> creates and stores an instance of
79L<DBIx::Class::ResultSource::Table>. Luckily, to use tables as result
80sources, you don't need to remember any of this.
81
82Result sources representing select queries, or views, can also be
83created, see L<DBIx::Class::ResultSource::View> for full details.
84
85=head2 Finding result source objects
86
87As mentioned above, a result source instance is created and stored for
88you when you define a
89L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
90
91You 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
117Creates a new ResultSource object.  Not normally called directly by end users.
118
119=cut
120
121sub 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
157Adds columns to the result source. If supplied colname => hashref
158pairs, uses the hashref as the L</column_info> for that column. Repeated
159calls of this method will add more columns, not replace them.
160
161The column names given will be created as accessor methods on your
162L<Result|DBIx::Class::Manual::ResultClass> objects. You can change the name of the accessor
163by supplying an L</accessor> in the column_info hash.
164
165If a column name beginning with a plus sign ('+col1') is provided, the
166attributes provided will be merged with any existing attributes for the
167column, with the new attributes taking precedence in the case that an
168attribute already exists. Using this without a hashref
169(C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
170it does the same thing it would do without the plus.
171
172The contents of the column_info are not set in stone. The following
173keys 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
191Use this to set the name of the accessor method for this column. If unset,
192the name of the column will be used.
193
194=item data_type
195
196   { data_type => 'integer' }
197
198This contains the column type. It is automatically filled if you use the
199L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
200L<DBIx::Class::Schema::Loader> module.
201
202Currently there is no standard set of values for the data_type. Use
203whatever your database supports.
204
205=item size
206
207   { size => 20 }
208
209The length of your column, if it is a column type that can have a size
210restriction. This is currently only used to create tables from your
211schema, see L<DBIx::Class::Schema/deploy>.
212
213   { size => [ 9, 6 ] }
214
215For decimal or float values you can specify an ArrayRef in order to
216control precision, assuming your database's
217L<SQL::Translator::Producer> supports it.
218
219=item is_nullable
220
221   { is_nullable => 1 }
222
223Set this to a true value for a column that is allowed to contain NULL
224values, default is false. This is currently only used to create tables
225from your schema, see L<DBIx::Class::Schema/deploy>.
226
227=item is_auto_increment
228
229   { is_auto_increment => 1 }
230
231Set this to a true value for a column whose value is somehow
232automatically set, defaults to false. This is used to determine which
233columns to empty when cloning objects using
234L<DBIx::Class::Row/copy>. It is also used by
235L<DBIx::Class::Schema/deploy>.
236
237=item is_numeric
238
239   { is_numeric => 1 }
240
241Set this to a true or false value (not C<undef>) to explicitly specify
242if this column contains numeric data. This controls how set_column
243decides whether to consider a column dirty after an update: if
244C<is_numeric> is true a numeric comparison C<< != >> will take place
245instead of the usual C<eq>
246
247If not specified the storage class will attempt to figure this out on
248first access to the column, based on the column C<data_type>. The
249result will be cached in this attribute.
250
251=item is_foreign_key
252
253   { is_foreign_key => 1 }
254
255Set this to a true value for a column that contains a key from a
256foreign table, defaults to false. This is currently only used to
257create tables from your schema, see L<DBIx::Class::Schema/deploy>.
258
259=item default_value
260
261   { default_value => \'now()' }
262
263Set this to the default value which will be inserted into a column by
264the database. Can contain either a value or a function (use a
265reference to a scalar e.g. C<\'now()'> if you want a function). This
266is currently only used to create tables from your schema, see
267L<DBIx::Class::Schema/deploy>.
268
269See the note on L<DBIx::Class::Row/new> for more information about possible
270issues related to db-side default values.
271
272=item sequence
273
274   { sequence => 'my_table_seq' }
275
276Set this on a primary key column to the name of the sequence used to
277generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
278will attempt to retrieve the name of the sequence from the database
279automatically.
280
281=item retrieve_on_insert
282
283  { retrieve_on_insert => 1 }
284
285For every column where this is set to true, DBIC will retrieve the RDBMS-side
286value upon a new row insertion (normally only the autoincrement PK is
287retrieved on insert). C<INSERT ... RETURNING> is used automatically if
288supported by the underlying storage, otherwise an extra SELECT statement is
289executed to retrieve the missing data.
290
291=item auto_nextval
292
293   { auto_nextval => 1 }
294
295Set this to a true value for a column whose value is retrieved automatically
296from a sequence or function (if supported by your Storage driver.) For a
297sequence, if you do not use a trigger to get the nextval, you have to set the
298L</sequence> value as well.
299
300Also set this for MSSQL columns with the 'uniqueidentifier'
301L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
302automatically generate using C<NEWID()>, unless they are a primary key in which
303case this will be done anyway.
304
305=item extra
306
307This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
308to 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
310column to unsigned. For more details, see
311L<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
327Add a single column and optional column info. Uses the same column
328info keys as L</add_columns>.
329
330=cut
331
332sub 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
357sub 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
371Returns true if the source has a column of this name, false otherwise.
372
373=cut
374
375sub 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
392Returns the column metadata hashref for a column, as originally passed
393to L</add_columns>. See L</add_columns> above for information on the
394contents of the hashref.
395
396=cut
397
398sub 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
442Returns all column names in the order they were declared to L</add_columns>.
443
444=cut
445
446sub 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
466Like L</column_info> but returns information for the requested columns. If
467the optional column-list arrayref is omitted it returns info on all columns
468currently defined on the ResultSource via L</add_columns>.
469
470=cut
471
472sub columns_info {
473  my ($self, $columns) = @_;
474
475  my $colinfo = $self->_columns;
476
477  if (
478    grep { ! $_->{data_type} } values %$colinfo
479      and
480    ! $self->{_columns_info_loaded}
481      and
482    $self->column_info_from_storage
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
540Removes the given list of columns by name, from the result source.
541
542B<Warning>: Removing a column that is also used in the sources primary
543key, or in one of the sources unique constraints, B<will> result in a
544broken 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
558Remove a single column by name from the result source, similar to
559L</remove_columns>.
560
561B<Warning>: Removing a column that is also used in the sources primary
562key, or in one of the sources unique constraints, B<will> result in a
563broken result source.
564
565=cut
566
567sub 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
582sub 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
594Defines one or more columns as primary key for this source. Must be
595called after L</add_columns>.
596
597Additionally, defines a L<unique constraint|/add_unique_constraint>
598named C<primary>.
599
600Note: you normally do want to define a primary key on your sources
601B<even if the underlying database table does not have a primary key>.
602See
603L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
604for more info.
605
606=cut
607
608sub 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
637Read-only accessor which returns the list of primary keys, supplied by
638L</set_primary_key>.
639
640=cut
641
642sub 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
649sub _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)
662sub _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
676Manually define the correct sequence for your table, to avoid the overhead
677associated with looking up the sequence automatically. The supplied sequence
678will 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
690sub 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
711Declare a unique constraint on this source. Call once for each unique
712constraint.
713
714  # For UNIQUE (column1, column2)
715  __PACKAGE__->add_unique_constraint(
716    constraint_name => [ qw/column1 column2/ ],
717  );
718
719Alternatively, you can specify only the columns:
720
721  __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
722
723This will result in a unique constraint named
724C<table_column1_column2>, where C<table> is replaced with the table
725name.
726
727Unique constraints are used, for example, when you pass the constraint
728name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
729only columns in the constraint are searched.
730
731Throws an error if any of the given column names do not yet exist on
732the result source.
733
734=cut
735
736sub 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
777Declare 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
784Alternatively, you can specify only the columns:
785
786  __PACKAGE__->add_unique_constraints(
787    [ qw/column1 column2/ ],
788    [ qw/column3 column4/ ]
789  );
790
791This will result in unique constraints named C<table_column1_column2> and
792C<table_column3_column4>, where C<table> is replaced with the table name.
793
794Throws an error if any of the given column names do not yet exist on
795the result source.
796
797See also L</add_unique_constraint>.
798
799=cut
800
801sub 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
834Return a name for a unique constraint containing the specified
835columns. The name is created by joining the table name and each column
836name, using an underscore character.
837
838For example, a constraint on a table named C<cd> containing the columns
839C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
840
841This is used by L</add_unique_constraint> if you do not specify the
842optional constraint name.
843
844=cut
845
846sub 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
868Read-only accessor which returns a hash of unique constraints on this
869source.
870
871The hash is keyed by constraint name, and contains an arrayref of
872column names as values.
873
874=cut
875
876sub 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
892Returns the list of unique constraint names defined on this source.
893
894=cut
895
896sub 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
916Returns the list of columns that make up the specified unique constraint.
917
918=cut
919
920sub 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
951An accessor to set a callback to be called during deployment of
952the schema via L<DBIx::Class::Schema/create_ddl_dir> or
953L<DBIx::Class::Schema/deploy>.
954
955The callback can be set as either a code reference or the name of a
956method in the current result class.
957
958Defaults to L</default_sqlt_deploy_hook>.
959
960Your callback will be passed the $source object representing the
961ResultSource instance being deployed, and the
962L<SQL::Translator::Schema::Table> object being created from it. The
963callback can be used to manipulate the table object or add your own
964customised indexes. If you need to manipulate a non-table object, use
965the L<DBIx::Class::Schema/sqlt_deploy_hook>.
966
967See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
968Your SQL> for examples.
969
970This sqlt deployment callback can only be used to manipulate
971SQL::Translator objects as they get turned into SQL. To execute
972post-deploy statements which SQL::Translator does not currently
973handle, override L<DBIx::Class::Schema/deploy> in your Schema class
974and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
975
976=head2 default_sqlt_deploy_hook
977
978This is the default deploy hook implementation which checks if your
979current Result class has a C<sqlt_deploy_hook> method, and if present
980invokes it B<on the Result class directly>. This is to preserve the
981semantics of C<sqlt_deploy_hook> which was originally designed to expect
982the Result class name and the
983L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being
984deployed.
985
986=cut
987
988sub 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
998sub _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
1022Set the default result class for this source. You can use this to create
1023and use your own result inflator. See L<DBIx::Class::ResultSet/result_class>
1024for more details.
1025
1026Please note that setting this to something like
1027L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed
1028and make life more difficult.  Inflators like those are better suited to
1029temporary 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
1041Returns a resultset for the given source. This will initially be created
1042on demand by calling
1043
1044  $self->resultset_class->new($self, $self->resultset_attributes)
1045
1046but 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
1068Set the class of the resultset. This is useful if you want to create your
1069own resultset methods. Create your own class derived from
1070L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1071this method returns the name of the existing resultset class, if one
1072exists.
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
1090Store a collection of resultset attributes, that will be set on every
1091L<DBIx::Class::ResultSet> produced from this result source.
1092
1093B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and
1094bugs! While C<resultset_attributes> isn't deprecated per se, its usage is
1095not recommended!
1096
1097Since relationships use attributes to link tables together, the "default"
1098attributes you set may cause unpredictable and undesired behavior.  Furthermore,
1099the defaults cannot be turned off, so you are stuck with them.
1100
1101In 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
1116This gives you the flexibility of not using it when you don't need it.
1117
1118For more complex situations, another solution would be to use a virtual view
1119via L<DBIx::Class::ResultSource::View>.
1120
1121=cut
1122
1123sub 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
1149Returns the name of the result source, which will typically be the table
1150name. This may be a scalar reference if the result source has a non-standard
1151name.
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
1163Set an alternate name for the result source when it is loaded into a schema.
1164This is useful if you want to refer to a result source by a name other than
1165its 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
1187Returns an expression of the source to be supplied to storage to specify
1188retrieval from this source. In the case of a database, the required FROM
1189clause contents.
1190
1191=cut
1192
1193sub from { die 'Virtual method!' }
1194
1195=head2 source_info
1196
1197Stores a hashref of per-source metadata.  No specific key names
1198have yet been standardized, the examples below are purely hypothetical
1199and 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
1218Sets and/or returns the L<DBIx::Class::Schema> object to which this
1219result source instance has been attached to.
1220
1221=cut
1222
1223sub 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
1254Returns the L<storage handle|DBIx::Class::Storage> for the current schema.
1255
1256=cut
1257
1258sub 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
1272L<DBIx::Class::Relationship> describes a series of methods which
1273create pre-defined useful types of relationships. Look there first
1274before using this method directly.
1275
1276The relationship name can be arbitrary, but must be unique for each
1277relationship attached to this result source. 'related_source' should
1278be the name with which the related result source was registered with
1279the current schema. For example:
1280
1281  $schema->source('Book')->add_relationship('reviews', 'Review', {
1282    'foreign.book_id' => 'self.id',
1283  });
1284
1285The condition C<$cond> needs to be an L<SQL::Abstract::Classic>-style
1286representation of the join between the tables. For example, if you're
1287creating a relation from Author to Book,
1288
1289  { 'foreign.author_id' => 'self.id' }
1290
1291will result in the JOIN clause
1292
1293  author me JOIN book foreign ON foreign.author_id = me.id
1294
1295You can specify as many foreign => self mappings as necessary.
1296
1297Valid attributes are as follows:
1298
1299=over 4
1300
1301=item join_type
1302
1303Explicitly specifies the type of join to use in the relationship. Any
1304SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1305the SQL command immediately before C<JOIN>.
1306
1307=item proxy
1308
1309An arrayref containing a list of accessors in the foreign class to proxy in
1310the main class. If, for example, you do the following:
1311
1312  CD->might_have(liner_notes => 'LinerNotes', undef, {
1313    proxy => [ qw/notes/ ],
1314  });
1315
1316Then, 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
1324Specifies the type of accessor that should be created for the
1325relationship. Valid values are C<single> (for when there is only a single
1326related object), C<multi> (when there can be many), and C<filter> (for
1327when there is a single related object, but you also want the relationship
1328accessor to double as a column accessor). For C<multi> accessors, an
1329add_to_* method is also created, which calls C<create_related> for the
1330relationship.
1331
1332=back
1333
1334Throws an exception if the condition is improperly supplied, or cannot
1335be resolved.
1336
1337=cut
1338
1339sub 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
1399Returns all relationship names for this source.
1400
1401=cut
1402
1403sub 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
1417Returns a hash of relationship information for the specified relationship
1418name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>.
1419
1420=cut
1421
1422sub 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
1437Returns true if the source has a relationship of this name, false otherwise.
1438
1439=cut
1440
1441sub 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
1456Looks through all the relationships on the source this relationship
1457points to, looking for one whose condition is the reverse of the
1458condition on this relationship.
1459
1460A common use of this is to find the name of the C<belongs_to> relation
1461opposing a C<has_many> relation. For definition of these look in
1462L<DBIx::Class::Relationship>.
1463
1464The returned hashref is keyed by the name of the opposing
1465relationship, and contains its data in the same manner as
1466L</relationship_info>.
1467
1468=cut
1469
1470sub 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
1530sub __strip_relcond {
1531  +{
1532    map
1533      { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
1534      keys %{$_[1]}
1535  }
1536}
1537
1538sub 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.
1545sub _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
1558sub _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
1580sub _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
1642sub _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                  grep { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
1713                ),
1714               -alias => $as,
1715               -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1,
1716             },
1717             scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join)
1718          ];
1719  }
1720}
1721
1722sub pk_depends_on {
1723  carp 'pk_depends_on is a private method, stop calling it';
1724  my $self = shift;
1725  $self->_pk_depends_on (@_);
1726}
1727
1728# Determines whether a relation is dependent on an object from this source
1729# having already been inserted. Takes the name of the relationship and a
1730# hashref of columns of the related object.
1731sub _pk_depends_on {
1732  my ($self, $rel_name, $rel_data) = @_;
1733
1734  my $relinfo = $self->relationship_info($rel_name);
1735
1736  # don't assume things if the relationship direction is specified
1737  return $relinfo->{attrs}{is_foreign_key_constraint}
1738    if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1739
1740  my $cond = $relinfo->{cond};
1741  return 0 unless ref($cond) eq 'HASH';
1742
1743  # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1744  my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1745
1746  # assume anything that references our PK probably is dependent on us
1747  # rather than vice versa, unless the far side is (a) defined or (b)
1748  # auto-increment
1749  my $rel_source = $self->related_source($rel_name);
1750
1751  foreach my $p ($self->primary_columns) {
1752    if (exists $keyhash->{$p}) {
1753      unless (defined($rel_data->{$keyhash->{$p}})
1754              || $rel_source->column_info($keyhash->{$p})
1755                            ->{is_auto_increment}) {
1756        return 0;
1757      }
1758    }
1759  }
1760
1761  return 1;
1762}
1763
1764sub resolve_condition {
1765  carp 'resolve_condition is a private method, stop calling it';
1766  shift->_resolve_condition (@_);
1767}
1768
1769sub _resolve_condition {
1770#  carp_unique sprintf
1771#    '_resolve_condition is a private method, and moreover is about to go '
1772#  . 'away. Please contact the development team at %s if you believe you '
1773#  . 'have a genuine use for this method, in order to discuss alternatives.',
1774#    DBIx::Class::_ENV_::HELP_URL,
1775#  ;
1776
1777#######################
1778### API Design? What's that...? (a backwards compatible shim, kill me now)
1779
1780  my ($self, $cond, @res_args, $rel_name);
1781
1782  # we *SIMPLY DON'T KNOW YET* which arg is which, yay
1783  ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_;
1784
1785  # assume that an undef is an object-like unset (set_from_related(undef))
1786  my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args);
1787
1788  # turn objlike into proper objects for saner code further down
1789  for (0,1) {
1790    next unless $is_objlike[$_];
1791
1792    if ( defined blessed $res_args[$_] ) {
1793
1794      # but wait - there is more!!! WHAT THE FUCK?!?!?!?!
1795      if ($res_args[$_]->isa('DBIx::Class::ResultSet')) {
1796        carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__');
1797        $is_objlike[$_] = 0;
1798        $res_args[$_] = '__gremlins__';
1799      }
1800    }
1801    else {
1802      $res_args[$_] ||= {};
1803
1804      # hate everywhere - have to pass in as a plain hash
1805      # pretending to be an object at least for now
1806      $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]")
1807        unless ref $res_args[$_] eq 'HASH';
1808    }
1809  }
1810
1811  my $args = {
1812    condition => $cond,
1813
1814    # where-is-waldo block guesses relname, then further down we override it if available
1815    (
1816      $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me',         self_result_object  => $res_args[1] )
1817    : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me',         foreign_alias => $res_args[1], foreign_values      => $res_args[0] )
1818    :                  ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0]                                      )
1819    ),
1820
1821    ( $rel_name ? ( rel_name => $rel_name ) : () ),
1822  };
1823#######################
1824
1825  # now it's fucking easy isn't it?!
1826  my $rc = $self->_resolve_relationship_condition( $args );
1827
1828  my @res = (
1829    ( $rc->{join_free_condition} || $rc->{condition} ),
1830    ! $rc->{join_free_condition},
1831  );
1832
1833  # _resolve_relationship_condition always returns qualified cols even in the
1834  # case of join_free_condition, but nothing downstream expects this
1835  if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') {
1836    $res[0] = { map
1837      { ($_ =~ /\.(.+)/) => $res[0]{$_} }
1838      keys %{$res[0]}
1839    };
1840  }
1841
1842  # and more legacy
1843  return wantarray ? @res : $res[0];
1844}
1845
1846# Keep this indefinitely. There is evidence of both CPAN and
1847# darkpan using it, and there isn't much harm in an extra var
1848# anyway.
1849our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION;
1850# YES I KNOW THIS IS EVIL
1851# it is there to save darkpan from themselves, since internally
1852# we are moving to a constant
1853Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1);
1854
1855# Resolves the passed condition to a concrete query fragment and extra
1856# metadata
1857#
1858## self-explanatory API, modeled on the custom cond coderef:
1859# rel_name              => (scalar)
1860# foreign_alias         => (scalar)
1861# foreign_values        => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef )
1862# self_alias            => (scalar)
1863# self_result_object    => (either not supplied or a result object)
1864# require_join_free_condition => (boolean, throws on failure to construct a JF-cond)
1865# infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition)
1866# condition             => (sqla cond struct, optional, defeaults to from $self->rel_info(rel_name)->{cond})
1867#
1868## returns a hash
1869# condition           => (a valid *likely fully qualified* sqla cond structure)
1870# identity_map        => (a hashref of foreign-to-self *unqualified* column equality names)
1871# join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset)
1872# inferred_values     => (in case of an available join_free condition, this is a hashref of
1873#                         *unqualified* column/value *EQUALITY* pairs, representing an amalgamation
1874#                         of the JF-cond parse and infer_values_based_on
1875#                         always either complete or unset)
1876#
1877sub _resolve_relationship_condition {
1878  my $self = shift;
1879
1880  my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1881
1882  for ( qw( rel_name self_alias foreign_alias ) ) {
1883    $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string")
1884      if !defined $args->{$_} or length ref $args->{$_};
1885  }
1886
1887  $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical")
1888    if $args->{self_alias} eq $args->{foreign_alias};
1889
1890# TEMP
1891  my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'";
1892
1893  my $rel_info = $self->relationship_info($args->{rel_name})
1894# TEMP
1895#    or $self->throw_exception( "No such $exception_rel_id" );
1896    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");
1897
1898# TEMP
1899  $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'"
1900    if $rel_info and exists $rel_info->{_original_name};
1901
1902  $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures")
1903    if exists $args->{self_result_object} and exists $args->{foreign_values};
1904
1905  $self->throw_exception( "Argument to infer_values_based_on must be a hash" )
1906    if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH';
1907
1908  $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on};
1909
1910  $args->{condition} ||= $rel_info->{cond};
1911
1912  $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" )
1913    if (
1914      exists $args->{self_result_object}
1915        and
1916      ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') )
1917    )
1918  ;
1919
1920#TEMP
1921  my $rel_rsrc;# = $self->related_source($args->{rel_name});
1922
1923  if (exists $args->{foreign_values}) {
1924# TEMP
1925    $rel_rsrc ||= $self->related_source($args->{rel_name});
1926
1927    if (defined blessed $args->{foreign_values}) {
1928
1929      $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" )
1930        unless $args->{foreign_values}->isa('DBIx::Class::Row');
1931
1932      carp_unique(
1933        "Objects supplied as 'foreign_values' ($args->{foreign_values}) "
1934      . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), "
1935      . "perhaps you've made a mistake invoking the condition resolver?"
1936      ) unless $args->{foreign_values}->isa($rel_rsrc->result_class);
1937
1938      $args->{foreign_values} = { $args->{foreign_values}->get_columns };
1939    }
1940    elsif (! defined $args->{foreign_values} or ref $args->{foreign_values} eq 'HASH') {
1941      my $ri = { map { $_ => 1 } $rel_rsrc->relationships };
1942      my $ci = $rel_rsrc->columns_info;
1943      ! exists $ci->{$_} and ! exists $ri->{$_} and $self->throw_exception(
1944        "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'"
1945      ) for keys %{ $args->{foreign_values} ||= {} };
1946    }
1947    else {
1948      $self->throw_exception(
1949        "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', "
1950      . "or a hash reference, or undef"
1951      );
1952    }
1953  }
1954
1955  my $ret;
1956
1957  if (ref $args->{condition} eq 'CODE') {
1958
1959    my $cref_args = {
1960      rel_name => $args->{rel_name},
1961      self_resultsource => $self,
1962      self_alias => $args->{self_alias},
1963      foreign_alias => $args->{foreign_alias},
1964      ( map
1965        { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () }
1966        qw( self_result_object foreign_values )
1967      ),
1968    };
1969
1970    # legacy - never remove these!!!
1971    $cref_args->{foreign_relname} = $cref_args->{rel_name};
1972
1973    $cref_args->{self_rowobj} = $cref_args->{self_result_object}
1974      if exists $cref_args->{self_result_object};
1975
1976    ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $args->{condition}->($cref_args);
1977
1978    # sanity check
1979    $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra")
1980      if @extra;
1981
1982    if (my $jfc = $ret->{join_free_condition}) {
1983
1984      $self->throw_exception (
1985        "The join-free condition returned for $exception_rel_id must be a hash reference"
1986      ) unless ref $jfc eq 'HASH';
1987
1988# TEMP
1989      $rel_rsrc ||= $self->related_source($args->{rel_name});
1990
1991      my ($joinfree_alias, $joinfree_source);
1992      if (defined $args->{self_result_object}) {
1993        $joinfree_alias = $args->{foreign_alias};
1994        $joinfree_source = $rel_rsrc;
1995      }
1996      elsif (defined $args->{foreign_values}) {
1997        $joinfree_alias = $args->{self_alias};
1998        $joinfree_source = $self;
1999      }
2000
2001      # FIXME sanity check until things stabilize, remove at some point
2002      $self->throw_exception (
2003        "A join-free condition returned for $exception_rel_id without a result object to chain from"
2004      ) unless $joinfree_alias;
2005
2006      my $fq_col_list = { map
2007        { ( "$joinfree_alias.$_" => 1 ) }
2008        $joinfree_source->columns
2009      };
2010
2011      exists $fq_col_list->{$_} or $self->throw_exception (
2012        "The join-free condition returned for $exception_rel_id may only "
2013      . 'contain keys that are fully qualified column names of the corresponding source '
2014      . "(it returned '$_')"
2015      ) for keys %$jfc;
2016
2017      (
2018        length ref $_
2019          and
2020        defined blessed($_)
2021          and
2022        $_->isa('DBIx::Class::Row')
2023          and
2024        $self->throw_exception (
2025          "The join-free condition returned for $exception_rel_id may not "
2026        . 'contain result objects as values - perhaps instead of invoking '
2027        . '->$something you meant to return ->get_column($something)'
2028        )
2029      ) for values %$jfc;
2030
2031    }
2032  }
2033  elsif (ref $args->{condition} eq 'HASH') {
2034
2035    # the condition is static - use parallel arrays
2036    # for a "pivot" depending on which side of the
2037    # rel did we get as an object
2038    my (@f_cols, @l_cols);
2039    for my $fc (keys %{$args->{condition}}) {
2040      my $lc = $args->{condition}{$fc};
2041
2042      # FIXME STRICTMODE should probably check these are valid columns
2043      $fc =~ s/^foreign\.// ||
2044        $self->throw_exception("Invalid rel cond key '$fc'");
2045
2046      $lc =~ s/^self\.// ||
2047        $self->throw_exception("Invalid rel cond val '$lc'");
2048
2049      push @f_cols, $fc;
2050      push @l_cols, $lc;
2051    }
2052
2053    # construct the crosstable condition and the identity map
2054    for  (0..$#f_cols) {
2055      $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" };
2056      $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_];
2057    };
2058
2059    if ($args->{foreign_values}) {
2060      $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]}
2061        for 0..$#f_cols;
2062    }
2063    elsif (defined $args->{self_result_object}) {
2064
2065      for my $i (0..$#l_cols) {
2066        if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) {
2067          $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]);
2068        }
2069        else {
2070          $self->throw_exception(sprintf
2071            "Unable to resolve relationship '%s' from object '%s': column '%s' not "
2072          . 'loaded from storage (or not passed to new() prior to insert()). You '
2073          . 'probably need to call ->discard_changes to get the server-side defaults '
2074          . 'from the database.',
2075            $args->{rel_name},
2076            $args->{self_result_object},
2077            $l_cols[$i],
2078          ) if $args->{self_result_object}->in_storage;
2079
2080          # FIXME - temporarly force-override
2081          delete $args->{require_join_free_condition};
2082          $ret->{join_free_condition} = UNRESOLVABLE_CONDITION;
2083          last;
2084        }
2085      }
2086    }
2087  }
2088  elsif (ref $args->{condition} eq 'ARRAY') {
2089    if (@{$args->{condition}} == 0) {
2090      $ret = {
2091        condition => UNRESOLVABLE_CONDITION,
2092        join_free_condition => UNRESOLVABLE_CONDITION,
2093      };
2094    }
2095    elsif (@{$args->{condition}} == 1) {
2096      $ret = $self->_resolve_relationship_condition({
2097        %$args,
2098        condition => $args->{condition}[0],
2099      });
2100    }
2101    else {
2102      # we are discarding inferred values here... likely incorrect...
2103      # then again - the entire thing is an OR, so we *can't* use them anyway
2104      for my $subcond ( map
2105        { $self->_resolve_relationship_condition({ %$args, condition => $_ }) }
2106        @{$args->{condition}}
2107      ) {
2108        $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition')
2109          if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) );
2110
2111        $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition));
2112      }
2113    }
2114  }
2115  else {
2116    $self->throw_exception ("Can't handle condition $args->{condition} for $exception_rel_id yet :(");
2117  }
2118
2119  $self->throw_exception(ucfirst "$exception_rel_id does not resolve to a join-free condition fragment") if (
2120    $args->{require_join_free_condition}
2121      and
2122    ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION )
2123  );
2124
2125  my $storage = $self->schema->storage;
2126
2127  # we got something back - sanity check and infer values if we can
2128  my @nonvalues;
2129  if ( my $jfc = $ret->{join_free_condition} and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION ) {
2130
2131    my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls');
2132
2133    if (keys %$jfc_eqs) {
2134
2135      for (keys %$jfc) {
2136        # $jfc is fully qualified by definition
2137        my ($col) = $_ =~ /\.(.+)/;
2138
2139        if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) {
2140          $ret->{inferred_values}{$col} = $jfc_eqs->{$_};
2141        }
2142        elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) {
2143          push @nonvalues, $col;
2144        }
2145      }
2146
2147      # all or nothing
2148      delete $ret->{inferred_values} if @nonvalues;
2149    }
2150  }
2151
2152  # did the user explicitly ask
2153  if ($args->{infer_values_based_on}) {
2154
2155    $self->throw_exception(sprintf (
2156      "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s",
2157      map { "'$_'" } @nonvalues
2158    )) if @nonvalues;
2159
2160
2161    $ret->{inferred_values} ||= {};
2162
2163    $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_}
2164      for keys %{$args->{infer_values_based_on}};
2165  }
2166
2167  # add the identities based on the main condition
2168  # (may already be there, since easy to calculate on the fly in the HASH case)
2169  if ( ! $ret->{identity_map} ) {
2170
2171    my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition});
2172
2173    my $colinfos;
2174    for my $lhs (keys %$col_eqs) {
2175
2176      next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION;
2177
2178# TEMP
2179      $rel_rsrc ||= $self->related_source($args->{rel_name});
2180
2181      # there is no way to know who is right and who is left in a cref
2182      # therefore a full blown resolution call, and figure out the
2183      # direction a bit further below
2184      $colinfos ||= $storage->_resolve_column_info([
2185        { -alias => $args->{self_alias}, -rsrc => $self },
2186        { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc },
2187      ]);
2188
2189      next unless $colinfos->{$lhs};  # someone is engaging in witchcraft
2190
2191      if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) {
2192
2193        if (
2194          $colinfos->{$rhs_ref->[0]}
2195            and
2196          $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias}
2197        ) {
2198          ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} )
2199            ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} )
2200            : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} )
2201          ;
2202        }
2203      }
2204      elsif (
2205        $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x
2206          and
2207        ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc
2208      ) {
2209        my ($lcol, $rcol) = map
2210          { $colinfos->{$_}{-colname} }
2211          ( $lhs, $1 )
2212        ;
2213        carp_unique(
2214          "The $exception_rel_id specifies equality of column '$lcol' and the "
2215        . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)"
2216        );
2217      }
2218    }
2219  }
2220
2221  # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition
2222  $ret->{condition} = { -and => [ $ret->{condition} ] }
2223    unless $ret->{condition} eq UNRESOLVABLE_CONDITION;
2224
2225  $ret;
2226}
2227
2228=head2 related_source
2229
2230=over 4
2231
2232=item Arguments: $rel_name
2233
2234=item Return Value: $source
2235
2236=back
2237
2238Returns the result source object for the given relationship.
2239
2240=cut
2241
2242sub related_source {
2243  my ($self, $rel) = @_;
2244  if( !$self->has_relationship( $rel ) ) {
2245    $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2246  }
2247
2248  # if we are not registered with a schema - just use the prototype
2249  # however if we do have a schema - ask for the source by name (and
2250  # throw in the process if all fails)
2251  if (my $schema = try { $self->schema }) {
2252    $schema->source($self->relationship_info($rel)->{source});
2253  }
2254  else {
2255    my $class = $self->relationship_info($rel)->{class};
2256    $self->ensure_class_loaded($class);
2257    $class->result_source_instance;
2258  }
2259}
2260
2261=head2 related_class
2262
2263=over 4
2264
2265=item Arguments: $rel_name
2266
2267=item Return Value: $classname
2268
2269=back
2270
2271Returns the class name for objects in the given relationship.
2272
2273=cut
2274
2275sub related_class {
2276  my ($self, $rel) = @_;
2277  if( !$self->has_relationship( $rel ) ) {
2278    $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2279  }
2280  return $self->schema->class($self->relationship_info($rel)->{source});
2281}
2282
2283=head2 handle
2284
2285=over 4
2286
2287=item Arguments: none
2288
2289=item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle>
2290
2291=back
2292
2293Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
2294for this source. Used as a serializable pointer to this resultsource, as it is not
2295easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
2296relationship definitions.
2297
2298=cut
2299
2300sub handle {
2301  return DBIx::Class::ResultSourceHandle->new({
2302    source_moniker => $_[0]->source_name,
2303
2304    # so that a detached thaw can be re-frozen
2305    $_[0]->{_detached_thaw}
2306      ? ( _detached_source  => $_[0]          )
2307      : ( schema            => $_[0]->schema  )
2308    ,
2309  });
2310}
2311
2312my $global_phase_destroy;
2313sub DESTROY {
2314  ### NO detected_reinvoked_destructor check
2315  ### This code very much relies on being called multuple times
2316
2317  return if $global_phase_destroy ||= in_global_destruction;
2318
2319######
2320# !!! ACHTUNG !!!!
2321######
2322#
2323# Under no circumstances shall $_[0] be stored anywhere else (like copied to
2324# a lexical variable, or shifted, or anything else). Doing so will mess up
2325# the refcount of this particular result source, and will allow the $schema
2326# we are trying to save to reattach back to the source we are destroying.
2327# The relevant code checking refcounts is in ::Schema::DESTROY()
2328
2329  # if we are not a schema instance holder - we don't matter
2330  return if(
2331    ! ref $_[0]->{schema}
2332      or
2333    isweak $_[0]->{schema}
2334  );
2335
2336  # weaken our schema hold forcing the schema to find somewhere else to live
2337  # during global destruction (if we have not yet bailed out) this will throw
2338  # which will serve as a signal to not try doing anything else
2339  # however beware - on older perls the exception seems randomly untrappable
2340  # due to some weird race condition during thread joining :(((
2341  local $@;
2342  eval {
2343    weaken $_[0]->{schema};
2344
2345    # if schema is still there reintroduce ourselves with strong refs back to us
2346    if ($_[0]->{schema}) {
2347      my $srcregs = $_[0]->{schema}->source_registrations;
2348      for (keys %$srcregs) {
2349        next unless $srcregs->{$_};
2350        $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
2351      }
2352    }
2353
2354    1;
2355  } or do {
2356    $global_phase_destroy = 1;
2357  };
2358
2359  return;
2360}
2361
2362sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
2363
2364sub STORABLE_thaw {
2365  my ($self, $cloning, $ice) = @_;
2366  %$self = %{ (Storable::thaw($ice))->resolve };
2367}
2368
2369=head2 throw_exception
2370
2371See L<DBIx::Class::Schema/"throw_exception">.
2372
2373=cut
2374
2375sub throw_exception {
2376  my $self = shift;
2377
2378  $self->{schema}
2379    ? $self->{schema}->throw_exception(@_)
2380    : DBIx::Class::Exception->throw(@_)
2381  ;
2382}
2383
2384=head2 column_info_from_storage
2385
2386=over
2387
2388=item Arguments: 1/0 (default: 0)
2389
2390=item Return Value: 1/0
2391
2392=back
2393
2394  __PACKAGE__->column_info_from_storage(1);
2395
2396Enables the on-demand automatic loading of the above column
2397metadata from storage as necessary.  This is *deprecated*, and
2398should not be used.  It will be removed before 1.0.
2399
2400=head1 FURTHER QUESTIONS?
2401
2402Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
2403
2404=head1 COPYRIGHT AND LICENSE
2405
2406This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
2407by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
2408redistribute it and/or modify it under the same terms as the
2409L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
2410
2411=cut
2412
24131;
2414