lib/DBIx/Class/ResultSource.pm

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