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