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