lib/DBIx/Class/ResultSource.pm

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