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