lib/DBIx/Class/ResultSource.pm

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