lib/DBIx/Class/ResultSource.pm

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