lib/DBIx/Class/ResultSource.pm

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