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   my $self = shift;
 808   my @constraints = @_;
 809
 810   if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) {
 811     # with constraint name
 812     while (my ($name, $constraint) = splice @constraints, 0, 2) {
 813       $self->add_unique_constraint($name => $constraint);
 814     }
 815   }
 816   else {
 817     # no constraint name
 818     foreach my $constraint (@constraints) {
 819       $self->add_unique_constraint($constraint);
 820     }
 821   }
 822 }
 823
 824 =head2 name_unique_constraint
 825
 826 =over 4
 827
 828 =item Arguments: \@colnames
 829
 830 =item Return Value: Constraint name
 831
 832 =back
 833
 834   $source->table('mytable');
 835   $source->name_unique_constraint(['col1', 'col2']);
 836   # returns
 837   'mytable_col1_col2'
 838
 839 Return a name for a unique constraint containing the specified
 840 columns. The name is created by joining the table name and each column
 841 name, using an underscore character.
 842
 843 For example, a constraint on a table named C<cd> containing the columns
 844 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 845
 846 This is used by L</add_unique_constraint> if you do not specify the
 847 optional constraint name.
 848
 849 =cut
 850
 851 sub name_unique_constraint {
 852   my ($self, $cols) = @_;
 853
 854   my $name = $self->name;
 855   $name = $$name if (ref $name eq 'SCALAR');
 856   $name =~ s/ ^ [^\.]+ \. //x;  # strip possible schema qualifier
 857
 858   return join '_', $name, @$cols;
 859 }
 860
 861 =head2 unique_constraints
 862
 863 =over 4
 864
 865 =item Arguments: none
 866
 867 =item Return Value: Hash of unique constraint data
 868
 869 =back
 870
 871   $source->unique_constraints();
 872
 873 Read-only accessor which returns a hash of unique constraints on this
 874 source.
 875
 876 The hash is keyed by constraint name, and contains an arrayref of
 877 column names as values.
 878
 879 =cut
 880
 881 sub unique_constraints {
 882   return %{shift->_unique_constraints||{}};
 883 }
 884
 885 =head2 unique_constraint_names
 886
 887 =over 4
 888
 889 =item Arguments: none
 890
 891 =item Return Value: Unique constraint names
 892
 893 =back
 894
 895   $source->unique_constraint_names();
 896
 897 Returns the list of unique constraint names defined on this source.
 898
 899 =cut
 900
 901 sub unique_constraint_names {
 902   my ($self) = @_;
 903
 904   my %unique_constraints = $self->unique_constraints;
 905
 906   return keys %unique_constraints;
 907 }
 908
 909 =head2 unique_constraint_columns
 910
 911 =over 4
 912
 913 =item Arguments: $constraintname
 914
 915 =item Return Value: List of constraint columns
 916
 917 =back
 918
 919   $source->unique_constraint_columns('myconstraint');
 920
 921 Returns the list of columns that make up the specified unique constraint.
 922
 923 =cut
 924
 925 sub unique_constraint_columns {
 926   my ($self, $constraint_name) = @_;
 927
 928   my %unique_constraints = $self->unique_constraints;
 929
 930   $self->throw_exception(
 931     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 932   ) unless exists $unique_constraints{$constraint_name};
 933
 934   return @{ $unique_constraints{$constraint_name} };
 935 }
 936
 937 =head2 sqlt_deploy_callback
 938
 939 =over
 940
 941 =item Arguments: $callback_name | \&callback_code
 942
 943 =item Return Value: $callback_name | \&callback_code
 944
 945 =back
 946
 947   __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod');
 948
 949    or
 950
 951   __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub {
 952     my ($source_instance, $sqlt_table) = @_;
 953     ...
 954   } );
 955
 956 An accessor to set a callback to be called during deployment of
 957 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
 958 L<DBIx::Class::Schema/deploy>.
 959
 960 The callback can be set as either a code reference or the name of a
 961 method in the current result class.
 962
 963 Defaults to L</default_sqlt_deploy_hook>.
 964
 965 Your callback will be passed the $source object representing the
 966 ResultSource instance being deployed, and the
 967 L<SQL::Translator::Schema::Table> object being created from it. The
 968 callback can be used to manipulate the table object or add your own
 969 customised indexes. If you need to manipulate a non-table object, use
 970 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
 971
 972 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
 973 Your SQL> for examples.
 974
 975 This sqlt deployment callback can only be used to manipulate
 976 SQL::Translator objects as they get turned into SQL. To execute
 977 post-deploy statements which SQL::Translator does not currently
 978 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
 979 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
 980
 981 =head2 default_sqlt_deploy_hook
 982
 983 This is the default deploy hook implementation which checks if your
 984 current Result class has a C<sqlt_deploy_hook> method, and if present
 985 invokes it B<on the Result class directly>. This is to preserve the
 986 semantics of C<sqlt_deploy_hook> which was originally designed to expect
 987 the Result class name and the
 988 L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being
 989 deployed.
 990
 991 =cut
 992
 993 sub default_sqlt_deploy_hook {
 994   my $self = shift;
 995
 996   my $class = $self->result_class;
 997
 998   if ($class and $class->can('sqlt_deploy_hook')) {
 999     $class->sqlt_deploy_hook(@_);
1000   }
1001 }
1002
1003 sub _invoke_sqlt_deploy_hook {
1004   my $self = shift;
1005   if ( my $hook = $self->sqlt_deploy_callback) {
1006     $self->$hook(@_);
1007   }
1008 }
1009
1010 =head2 result_class
1011
1012 =over 4
1013
1014 =item Arguments: $classname
1015
1016 =item Return Value: $classname
1017
1018 =back
1019
1020  use My::Schema::ResultClass::Inflator;
1021  ...
1022
1023  use My::Schema::Artist;
1024  ...
1025  __PACKAGE__->result_class('My::Schema::ResultClass::Inflator');
1026
1027 Set the default result class for this source. You can use this to create
1028 and use your own result inflator. See L<DBIx::Class::ResultSet/result_class>
1029 for more details.
1030
1031 Please note that setting this to something like
1032 L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed
1033 and make life more difficult.  Inflators like those are better suited to
1034 temporary usage via L<DBIx::Class::ResultSet/result_class>.
1035
1036 =head2 resultset
1037
1038 =over 4
1039
1040 =item Arguments: none
1041
1042 =item Return Value: L<$resultset|DBIx::Class::ResultSet>
1043
1044 =back
1045
1046 Returns a resultset for the given source. This will initially be created
1047 on demand by calling
1048
1049   $self->resultset_class->new($self, $self->resultset_attributes)
1050
1051 but is cached from then on unless resultset_class changes.
1052
1053 =head2 resultset_class
1054
1055 =over 4
1056
1057 =item Arguments: $classname
1058
1059 =item Return Value: $classname
1060
1061 =back
1062
1063   package My::Schema::ResultSet::Artist;
1064   use base 'DBIx::Class::ResultSet';
1065   ...
1066
1067   # In the result class
1068   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
1069
1070   # Or in code
1071   $source->resultset_class('My::Schema::ResultSet::Artist');
1072
1073 Set the class of the resultset. This is useful if you want to create your
1074 own resultset methods. Create your own class derived from
1075 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1076 this method returns the name of the existing resultset class, if one
1077 exists.
1078
1079 =head2 resultset_attributes
1080
1081 =over 4
1082
1083 =item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1084
1085 =item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
1086
1087 =back
1088
1089   # In the result class
1090   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
1091
1092   # Or in code
1093   $source->resultset_attributes({ order_by => [ 'id' ] });
1094
1095 Store a collection of resultset attributes, that will be set on every
1096 L<DBIx::Class::ResultSet> produced from this result source.
1097
1098 B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and
1099 bugs! While C<resultset_attributes> isn't deprecated per se, its usage is
1100 not recommended!
1101
1102 Since relationships use attributes to link tables together, the "default"
1103 attributes you set may cause unpredictable and undesired behavior.  Furthermore,
1104 the defaults cannot be turned off, so you are stuck with them.
1105
1106 In most cases, what you should actually be using are project-specific methods:
1107
1108   package My::Schema::ResultSet::Artist;
1109   use base 'DBIx::Class::ResultSet';
1110   ...
1111
1112   # BAD IDEA!
1113   #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' });
1114
1115   # GOOD IDEA!
1116   sub with_tracks { shift->search({}, { prefetch => 'tracks' }) }
1117
1118   # in your code
1119   $schema->resultset('Artist')->with_tracks->...
1120
1121 This gives you the flexibility of not using it when you don't need it.
1122
1123 For more complex situations, another solution would be to use a virtual view
1124 via L<DBIx::Class::ResultSource::View>.
1125
1126 =cut
1127
1128 sub resultset {
1129   my $self = shift;
1130   $self->throw_exception(
1131     'resultset does not take any arguments. If you want another resultset, '.
1132     'call it on the schema instead.'
1133   ) if scalar @_;
1134
1135   $self->resultset_class->new(
1136     $self,
1137     {
1138       ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ),
1139       %{$self->{resultset_attributes}},
1140     },
1141   );
1142 }
1143
1144 =head2 name
1145
1146 =over 4
1147
1148 =item Arguments: none
1149
1150 =item Result value: $name
1151
1152 =back
1153
1154 Returns the name of the result source, which will typically be the table
1155 name. This may be a scalar reference if the result source has a non-standard
1156 name.
1157
1158 =head2 source_name
1159
1160 =over 4
1161
1162 =item Arguments: $source_name
1163
1164 =item Result value: $source_name
1165
1166 =back
1167
1168 Set an alternate name for the result source when it is loaded into a schema.
1169 This is useful if you want to refer to a result source by a name other than
1170 its class name.
1171
1172   package ArchivedBooks;
1173   use base qw/DBIx::Class/;
1174   __PACKAGE__->table('books_archive');
1175   __PACKAGE__->source_name('Books');
1176
1177   # from your schema...
1178   $schema->resultset('Books')->find(1);
1179
1180 =head2 from
1181
1182 =over 4
1183
1184 =item Arguments: none
1185
1186 =item Return Value: FROM clause
1187
1188 =back
1189
1190   my $from_clause = $source->from();
1191
1192 Returns an expression of the source to be supplied to storage to specify
1193 retrieval from this source. In the case of a database, the required FROM
1194 clause contents.
1195
1196 =cut
1197
1198 sub from { die 'Virtual method!' }
1199
1200 =head2 source_info
1201
1202 Stores a hashref of per-source metadata.  No specific key names
1203 have yet been standardized, the examples below are purely hypothetical
1204 and don't actually accomplish anything on their own:
1205
1206   __PACKAGE__->source_info({
1207     "_tablespace" => 'fast_disk_array_3',
1208     "_engine" => 'InnoDB',
1209   });
1210
1211 =head2 schema
1212
1213 =over 4
1214
1215 =item Arguments: L<$schema?|DBIx::Class::Schema>
1216
1217 =item Return Value: L<$schema|DBIx::Class::Schema>
1218
1219 =back
1220
1221   my $schema = $source->schema();
1222
1223 Sets and/or returns the L<DBIx::Class::Schema> object to which this
1224 result source instance has been attached to.
1225
1226 =cut
1227
1228 sub schema {
1229   if (@_ > 1) {
1230     $_[0]->{schema} = $_[1];
1231   }
1232   else {
1233     $_[0]->{schema} || do {
1234       my $name = $_[0]->{source_name} || '_unnamed_';
1235       my $err = 'Unable to perform storage-dependent operations with a detached result source '
1236               . "(source '$name' is not associated with a schema).";
1237
1238       $err .= ' You need to use $schema->thaw() or manually set'
1239             . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
1240         if $_[0]->{_detached_thaw};
1241
1242       DBIx::Class::Exception->throw($err);
1243     };
1244   }
1245 }
1246
1247 =head2 storage
1248
1249 =over 4
1250
1251 =item Arguments: none
1252
1253 =item Return Value: L<$storage|DBIx::Class::Storage>
1254
1255 =back
1256
1257   $source->storage->debug(1);
1258
1259 Returns the L<storage handle|DBIx::Class::Storage> for the current schema.
1260
1261 =cut
1262
1263 sub storage {
1264   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
1265   $_[0]->schema->storage
1266 }
1267
1268 =head2 add_relationship
1269
1270 =over 4
1271
1272 =item Arguments: $rel_name, $related_source_name, \%cond, \%attrs?
1273
1274 =item Return Value: 1/true if it succeeded
1275
1276 =back
1277
1278   $source->add_relationship('rel_name', 'related_source', $cond, $attrs);
1279
1280 L<DBIx::Class::Relationship> describes a series of methods which
1281 create pre-defined useful types of relationships. Look there first
1282 before using this method directly.
1283
1284 The relationship name can be arbitrary, but must be unique for each
1285 relationship attached to this result source. 'related_source' should
1286 be the name with which the related result source was registered with
1287 the current schema. For example:
1288
1289   $schema->source('Book')->add_relationship('reviews', 'Review', {
1290     'foreign.book_id' => 'self.id',
1291   });
1292
1293 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1294 representation of the join between the tables. For example, if you're
1295 creating a relation from Author to Book,
1296
1297   { 'foreign.author_id' => 'self.id' }
1298
1299 will result in the JOIN clause
1300
1301   author me JOIN book foreign ON foreign.author_id = me.id
1302
1303 You can specify as many foreign => self mappings as necessary.
1304
1305 Valid attributes are as follows:
1306
1307 =over 4
1308
1309 =item join_type
1310
1311 Explicitly specifies the type of join to use in the relationship. Any
1312 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1313 the SQL command immediately before C<JOIN>.
1314
1315 =item proxy
1316
1317 An arrayref containing a list of accessors in the foreign class to proxy in
1318 the main class. If, for example, you do the following:
1319
1320   CD->might_have(liner_notes => 'LinerNotes', undef, {
1321     proxy => [ qw/notes/ ],
1322   });
1323
1324 Then, assuming LinerNotes has an accessor named notes, you can do:
1325
1326   my $cd = CD->find(1);
1327   # set notes -- LinerNotes object is created if it doesn't exist
1328   $cd->notes('Notes go here');
1329
1330 =item accessor
1331
1332 Specifies the type of accessor that should be created for the
1333 relationship. Valid values are C<single> (for when there is only a single
1334 related object), C<multi> (when there can be many), and C<filter> (for
1335 when there is a single related object, but you also want the relationship
1336 accessor to double as a column accessor). For C<multi> accessors, an
1337 add_to_* method is also created, which calls C<create_related> for the
1338 relationship.
1339
1340 =back
1341
1342 Throws an exception if the condition is improperly supplied, or cannot
1343 be resolved.
1344
1345 =cut
1346
1347 sub add_relationship {
1348   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1349   $self->throw_exception("Can't create relationship without join condition")
1350     unless $cond;
1351   $attrs ||= {};
1352
1353   # Check foreign and self are right in cond
1354   if ( (ref $cond ||'') eq 'HASH') {
1355     $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'")
1356       for keys %$cond;
1357
1358     $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'")
1359       for values %$cond;
1360   }
1361
1362   my %rels = %{ $self->_relationships };
1363   $rels{$rel} = { class => $f_source_name,
1364                   source => $f_source_name,
1365                   cond  => $cond,
1366                   attrs => $attrs };
1367   $self->_relationships(\%rels);
1368
1369   return $self;
1370 }
1371
1372 =head2 relationships
1373
1374 =over 4
1375
1376 =item Arguments: none
1377
1378 =item Return Value: L<@rel_names|DBIx::Class::Relationship>
1379
1380 =back
1381
1382   my @rel_names = $source->relationships();
1383
1384 Returns all relationship names for this source.
1385
1386 =cut
1387
1388 sub relationships {
1389   keys %{$_[0]->_relationships};
1390 }
1391
1392 =head2 relationship_info
1393
1394 =over 4
1395
1396 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1397
1398 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1399
1400 =back
1401
1402 Returns a hash of relationship information for the specified relationship
1403 name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>.
1404
1405 =cut
1406
1407 sub relationship_info {
1408   #my ($self, $rel) = @_;
1409   return shift->_relationships->{+shift};
1410 }
1411
1412 =head2 has_relationship
1413
1414 =over 4
1415
1416 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1417
1418 =item Return Value: 1/0 (true/false)
1419
1420 =back
1421
1422 Returns true if the source has a relationship of this name, false otherwise.
1423
1424 =cut
1425
1426 sub has_relationship {
1427   #my ($self, $rel) = @_;
1428   return exists shift->_relationships->{+shift};
1429 }
1430
1431 =head2 reverse_relationship_info
1432
1433 =over 4
1434
1435 =item Arguments: L<$rel_name|DBIx::Class::Relationship>
1436
1437 =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship>
1438
1439 =back
1440
1441 Looks through all the relationships on the source this relationship
1442 points to, looking for one whose condition is the reverse of the
1443 condition on this relationship.
1444
1445 A common use of this is to find the name of the C<belongs_to> relation
1446 opposing a C<has_many> relation. For definition of these look in
1447 L<DBIx::Class::Relationship>.
1448
1449 The returned hashref is keyed by the name of the opposing
1450 relationship, and contains its data in the same manner as
1451 L</relationship_info>.
1452
1453 =cut
1454
1455 sub reverse_relationship_info {
1456   my ($self, $rel) = @_;
1457
1458   my $rel_info = $self->relationship_info($rel)
1459     or $self->throw_exception("No such relationship '$rel'");
1460
1461   my $ret = {};
1462
1463   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1464
1465   my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
1466
1467   my $registered_source_name = $self->source_name;
1468
1469   # this may be a partial schema or something else equally esoteric
1470   my $other_rsrc = $self->related_source($rel);
1471
1472   # Get all the relationships for that source that related to this source
1473   # whose foreign column set are our self columns on $rel and whose self
1474   # columns are our foreign columns on $rel
1475   foreach my $other_rel ($other_rsrc->relationships) {
1476
1477     # only consider stuff that points back to us
1478     # "us" here is tricky - if we are in a schema registration, we want
1479     # to use the source_names, otherwise we will use the actual classes
1480
1481     # the schema may be partial
1482     my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
1483       or next;
1484
1485     if ($registered_source_name) {
1486       next if $registered_source_name ne ($roundtrip_rsrc->source_name || '')
1487     }
1488     else {
1489       next if $self->result_class ne $roundtrip_rsrc->result_class;
1490     }
1491
1492     my $other_rel_info = $other_rsrc->relationship_info($other_rel);
1493
1494     # this can happen when we have a self-referential class
1495     next if $other_rel_info eq $rel_info;
1496
1497     next unless ref $other_rel_info->{cond} eq 'HASH';
1498     my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
1499
1500     $ret->{$other_rel} = $other_rel_info if (
1501       $self->_compare_relationship_keys (
1502         [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
1503       )
1504         and
1505       $self->_compare_relationship_keys (
1506         [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
1507       )
1508     );
1509   }
1510
1511   return $ret;
1512 }
1513
1514 # all this does is removes the foreign/self prefix from a condition
1515 sub __strip_relcond {
1516   +{
1517     map
1518       { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
1519       keys %{$_[1]}
1520   }
1521 }
1522
1523 sub compare_relationship_keys {
1524   carp 'compare_relationship_keys is a private method, stop calling it';
1525   my $self = shift;
1526   $self->_compare_relationship_keys (@_);
1527 }
1528
1529 # Returns true if both sets of keynames are the same, false otherwise.
1530 sub _compare_relationship_keys {
1531 #  my ($self, $keys1, $keys2) = @_;
1532   return
1533     join ("\x00", sort @{$_[1]})
1534       eq
1535     join ("\x00", sort @{$_[2]})
1536   ;
1537 }
1538
1539 # optionally takes either an arrayref of column names, or a hashref of already
1540 # retrieved colinfos
1541 # returns an arrayref of column names of the shortest unique constraint
1542 # (matching some of the input if any), giving preference to the PK
1543 sub _identifying_column_set {
1544   my ($self, $cols) = @_;
1545
1546   my %unique = $self->unique_constraints;
1547   my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||());
1548
1549   # always prefer the PK first, and then shortest constraints first
1550   USET:
1551   for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) {
1552     next unless $set && @$set;
1553
1554     for (@$set) {
1555       next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} );
1556     }
1557
1558     # copy so we can mangle it at will
1559     return [ @$set ];
1560   }
1561
1562   return undef;
1563 }
1564
1565 sub _minimal_valueset_satisfying_constraint {
1566   my $self = shift;
1567   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1568
1569   $args->{columns_info} ||= $self->columns_info;
1570
1571   my $vals = $self->schema->storage->_extract_fixed_condition_columns(
1572     $args->{values},
1573     ($args->{carp_on_nulls} ? 'consider_nulls' : undef ),
1574   );
1575
1576   my $cols;
1577   for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) {
1578     if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) {
1579       $cols->{missing}{$col} = undef;
1580     }
1581     elsif( ! defined $vals->{$col} ) {
1582       $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef;
1583     }
1584     else {
1585       # we need to inject back the '=' as _extract_fixed_condition_columns
1586       # will strip it from literals and values alike, resulting in an invalid
1587       # condition in the end
1588       $cols->{present}{$col} = { '=' => $vals->{$col} };
1589     }
1590
1591     $cols->{fc}{$col} = 1 if (
1592       ( ! $cols->{missing} or ! exists $cols->{missing}{$col} )
1593         and
1594       keys %{ $args->{columns_info}{$col}{_filter_info} || {} }
1595     );
1596   }
1597
1598   $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s",
1599     $args->{constraint_name},
1600     join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ),
1601   ) ) if $cols->{missing};
1602
1603   $self->throw_exception( sprintf (
1604     "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s",
1605     $args->{constraint_name},
1606     join (', ', map { "'$_'" } sort keys %{$cols->{fc}}),
1607   )) if $cols->{fc};
1608
1609   if (
1610     $cols->{undefined}
1611       and
1612     !$ENV{DBIC_NULLABLE_KEY_NOWARN}
1613   ) {
1614     carp_unique ( sprintf (
1615       "NULL/undef values supplied for requested unique constraint '%s' (NULL "
1616     . 'values in column(s): %s). This is almost certainly not what you wanted, '
1617     . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
1618       $args->{constraint_name},
1619       join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}),
1620     ));
1621   }
1622
1623   return { map { %{ $cols->{$_}||{} } } qw(present undefined) };
1624 }
1625
1626 # Returns the {from} structure used to express JOIN conditions
1627 sub _resolve_join {
1628   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1629
1630   # we need a supplied one, because we do in-place modifications, no returns
1631   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1632     unless ref $seen eq 'HASH';
1633
1634   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1635     unless ref $jpath eq 'ARRAY';
1636
1637   $jpath = [@$jpath]; # copy
1638
1639   if (not defined $join or not length $join) {
1640     return ();
1641   }
1642   elsif (ref $join eq 'ARRAY') {
1643     return
1644       map {
1645         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1646       } @$join;
1647   }
1648   elsif (ref $join eq 'HASH') {
1649
1650     my @ret;
1651     for my $rel (keys %$join) {
1652
1653       my $rel_info = $self->relationship_info($rel)
1654         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1655
1656       my $force_left = $parent_force_left;
1657       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1658
1659       # the actual seen value will be incremented by the recursion
1660       my $as = $self->schema->storage->relname_to_table_alias(
1661         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1662       );
1663
1664       push @ret, (
1665         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1666         $self->related_source($rel)->_resolve_join(
1667           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1668         )
1669       );
1670     }
1671     return @ret;
1672
1673   }
1674   elsif (ref $join) {
1675     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1676   }
1677   else {
1678     my $count = ++$seen->{$join};
1679     my $as = $self->schema->storage->relname_to_table_alias(
1680       $join, ($count > 1 && $count)
1681     );
1682
1683     my $rel_info = $self->relationship_info($join)
1684       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1685
1686     my $rel_src = $self->related_source($join);
1687     return [ { $as => $rel_src->from,
1688                -rsrc => $rel_src,
1689                -join_type => $parent_force_left
1690                   ? 'left'
1691                   : $rel_info->{attrs}{join_type}
1692                 ,
1693                -join_path => [@$jpath, { $join => $as } ],
1694                -is_single => (
1695                   ! $rel_info->{attrs}{accessor}
1696                     or
1697                   $rel_info->{attrs}{accessor} eq 'single'
1698                     or
1699                   $rel_info->{attrs}{accessor} eq 'filter'
1700                 ),
1701                -alias => $as,
1702                -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1,
1703              },
1704              $self->_resolve_relationship_condition(
1705                rel_name => $join,
1706                self_alias => $alias,
1707                foreign_alias => $as,
1708              )->{condition},
1709           ];
1710   }
1711 }
1712
1713 sub pk_depends_on {
1714   carp 'pk_depends_on is a private method, stop calling it';
1715   my $self = shift;
1716   $self->_pk_depends_on (@_);
1717 }
1718
1719 # Determines whether a relation is dependent on an object from this source
1720 # having already been inserted. Takes the name of the relationship and a
1721 # hashref of columns of the related object.
1722 sub _pk_depends_on {
1723   my ($self, $rel_name, $rel_data) = @_;
1724
1725   my $relinfo = $self->relationship_info($rel_name);
1726
1727   # don't assume things if the relationship direction is specified
1728   return $relinfo->{attrs}{is_foreign_key_constraint}
1729     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1730
1731   my $cond = $relinfo->{cond};
1732   return 0 unless ref($cond) eq 'HASH';
1733
1734   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1735   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1736
1737   # assume anything that references our PK probably is dependent on us
1738   # rather than vice versa, unless the far side is (a) defined or (b)
1739   # auto-increment
1740   my $rel_source = $self->related_source($rel_name);
1741
1742   foreach my $p ($self->primary_columns) {
1743     if (exists $keyhash->{$p}) {
1744       unless (defined($rel_data->{$keyhash->{$p}})
1745               || $rel_source->column_info($keyhash->{$p})
1746                             ->{is_auto_increment}) {
1747         return 0;
1748       }
1749     }
1750   }
1751
1752   return 1;
1753 }
1754
1755 sub resolve_condition {
1756   carp 'resolve_condition is a private method, stop calling it';
1757   shift->_resolve_condition (@_);
1758 }
1759
1760 sub _resolve_condition {
1761 #  carp_unique sprintf
1762 #    '_resolve_condition is a private method, and moreover is about to go '
1763 #  . 'away. Please contact the development team at %s if you believe you '
1764 #  . 'have a genuine use for this method, in order to discuss alternatives.',
1765 #    DBIx::Class::_ENV_::HELP_URL,
1766 #  ;
1767
1768 #######################
1769 ### API Design? What's that...? (a backwards compatible shim, kill me now)
1770
1771   my ($self, $cond, @res_args, $rel_name);
1772
1773   # we *SIMPLY DON'T KNOW YET* which arg is which, yay
1774   ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_;
1775
1776   # assume that an undef is an object-like unset (set_from_related(undef))
1777   my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args);
1778
1779   # turn objlike into proper objects for saner code further down
1780   for (0,1) {
1781     next unless $is_objlike[$_];
1782
1783     if ( defined blessed $res_args[$_] ) {
1784
1785       # but wait - there is more!!! WHAT THE FUCK?!?!?!?!
1786       if ($res_args[$_]->isa('DBIx::Class::ResultSet')) {
1787         carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__');
1788         $is_objlike[$_] = 0;
1789         $res_args[$_] = '__gremlins__';
1790       }
1791     }
1792     else {
1793       $res_args[$_] ||= {};
1794
1795       # hate everywhere - have to pass in as a plain hash
1796       # pretending to be an object at least for now
1797       $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]")
1798         unless ref $res_args[$_] eq 'HASH';
1799     }
1800   }
1801
1802   my $args = {
1803     # where-is-waldo block guesses relname, then further down we override it if available
1804     (
1805       $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me',         self_result_object  => $res_args[1] )
1806     : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me',         foreign_alias => $res_args[1], foreign_values      => $res_args[0] )
1807     :                  ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0]                                      )
1808     ),
1809
1810     ( $rel_name ? ( rel_name => $rel_name ) : () ),
1811   };
1812
1813   # Allowing passing relconds different than the relationshup itself is cute,
1814   # but likely dangerous. Remove that from the (still unofficial) API of
1815   # _resolve_relationship_condition, and instead make it "hard on purpose"
1816   local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond;
1817
1818 #######################
1819
1820   # now it's fucking easy isn't it?!
1821   my $rc = $self->_resolve_relationship_condition( $args );
1822
1823   my @res = (
1824     ( $rc->{join_free_condition} || $rc->{condition} ),
1825     ! $rc->{join_free_condition},
1826   );
1827
1828   # _resolve_relationship_condition always returns qualified cols even in the
1829   # case of join_free_condition, but nothing downstream expects this
1830   if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') {
1831     $res[0] = { map
1832       { ($_ =~ /\.(.+)/) => $res[0]{$_} }
1833       keys %{$res[0]}
1834     };
1835   }
1836
1837   # and more legacy
1838   return wantarray ? @res : $res[0];
1839 }
1840
1841 # Keep this indefinitely. There is evidence of both CPAN and
1842 # darkpan using it, and there isn't much harm in an extra var
1843 # anyway.
1844 our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION;
1845 # YES I KNOW THIS IS EVIL
1846 # it is there to save darkpan from themselves, since internally
1847 # we are moving to a constant
1848 Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1);
1849
1850 # Resolves the passed condition to a concrete query fragment and extra
1851 # metadata
1852 #
1853 ## self-explanatory API, modeled on the custom cond coderef:
1854 # rel_name              => (scalar)
1855 # foreign_alias         => (scalar)
1856 # foreign_values        => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef )
1857 # self_alias            => (scalar)
1858 # self_result_object    => (either not supplied or a result object)
1859 # require_join_free_condition => (boolean, throws on failure to construct a JF-cond)
1860 # infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition)
1861 #
1862 ## returns a hash
1863 # condition           => (a valid *likely fully qualified* sqla cond structure)
1864 # identity_map        => (a hashref of foreign-to-self *unqualified* column equality names)
1865 # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset)
1866 # inferred_values     => (in case of an available join_free condition, this is a hashref of
1867 #                         *unqualified* column/value *EQUALITY* pairs, representing an amalgamation
1868 #                         of the JF-cond parse and infer_values_based_on
1869 #                         always either complete or unset)
1870 #
1871 sub _resolve_relationship_condition {
1872   my $self = shift;
1873
1874   my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ };
1875
1876   for ( qw( rel_name self_alias foreign_alias ) ) {
1877     $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string")
1878       if !defined $args->{$_} or length ref $args->{$_};
1879   }
1880
1881   $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical")
1882     if $args->{self_alias} eq $args->{foreign_alias};
1883
1884 # TEMP
1885   my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'";
1886
1887   my $rel_info = $self->relationship_info($args->{rel_name})
1888 # TEMP
1889 #    or $self->throw_exception( "No such $exception_rel_id" );
1890     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");
1891
1892 # TEMP
1893   $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'"
1894     if $rel_info and exists $rel_info->{_original_name};
1895
1896   $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures")
1897     if exists $args->{self_result_object} and exists $args->{foreign_values};
1898
1899   $self->throw_exception( "Argument to infer_values_based_on must be a hash" )
1900     if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH';
1901
1902   $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on};
1903
1904   $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" )
1905     if (
1906       exists $args->{self_result_object}
1907         and
1908       ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') )
1909     )
1910   ;
1911
1912   my $rel_rsrc = $self->related_source($args->{rel_name});
1913   my $storage = $self->schema->storage;
1914
1915   if (exists $args->{foreign_values}) {
1916
1917     if (! defined $args->{foreign_values} ) {
1918       # fallback: undef => {}
1919       $args->{foreign_values} = {};
1920     }
1921     elsif (defined blessed $args->{foreign_values}) {
1922
1923       $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" )
1924         unless $args->{foreign_values}->isa('DBIx::Class::Row');
1925
1926       carp_unique(
1927         "Objects supplied as 'foreign_values' ($args->{foreign_values}) "
1928       . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), "
1929       . "perhaps you've made a mistake invoking the condition resolver?"
1930       ) unless $args->{foreign_values}->isa($rel_rsrc->result_class);
1931
1932       $args->{foreign_values} = { $args->{foreign_values}->get_columns };
1933     }
1934     elsif ( ref $args->{foreign_values} eq 'HASH' ) {
1935
1936       # re-build {foreign_values} excluding identically named rels
1937       if( keys %{$args->{foreign_values}} ) {
1938
1939         my ($col_idx, $rel_idx) = map
1940           { { map { $_ => 1 } $rel_rsrc->$_ } }
1941           qw( columns relationships )
1942         ;
1943
1944         my $equivalencies = $storage->_extract_fixed_condition_columns(
1945           $args->{foreign_values},
1946           'consider nulls',
1947         );
1948
1949         $args->{foreign_values} = { map {
1950           # skip if relationship *and* a non-literal ref
1951           # this means a multicreate stub was passed in
1952           (
1953             $rel_idx->{$_}
1954               and
1955             length ref $args->{foreign_values}{$_}
1956               and
1957             ! is_literal_value($args->{foreign_values}{$_})
1958           )
1959             ? ()
1960             : ( $_ => (
1961                 ! $col_idx->{$_}
1962                   ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" )
1963               : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION )
1964                   ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" )
1965               : $args->{foreign_values}{$_}
1966             ))
1967         } keys %{$args->{foreign_values}} };
1968       }
1969     }
1970     else {
1971       $self->throw_exception(
1972         "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', "
1973       . "or a hash reference, or undef"
1974       );
1975     }
1976   }
1977
1978   my $ret;
1979
1980   if (ref $rel_info->{cond} eq 'CODE') {
1981
1982     my $cref_args = {
1983       rel_name => $args->{rel_name},
1984       self_resultsource => $self,
1985       self_alias => $args->{self_alias},
1986       foreign_alias => $args->{foreign_alias},
1987       ( map
1988         { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () }
1989         qw( self_result_object foreign_values )
1990       ),
1991     };
1992
1993     # legacy - never remove these!!!
1994     $cref_args->{foreign_relname} = $cref_args->{rel_name};
1995
1996     $cref_args->{self_rowobj} = $cref_args->{self_result_object}
1997       if exists $cref_args->{self_result_object};
1998
1999     ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $rel_info->{cond}->($cref_args);
2000
2001     # sanity check
2002     $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra")
2003       if @extra;
2004
2005     if (my $jfc = $ret->{join_free_condition}) {
2006
2007       $self->throw_exception (
2008         "The join-free condition returned for $exception_rel_id must be a hash reference"
2009       ) unless ref $jfc eq 'HASH';
2010
2011       my ($joinfree_alias, $joinfree_source);
2012       if (defined $args->{self_result_object}) {
2013         $joinfree_alias = $args->{foreign_alias};
2014         $joinfree_source = $rel_rsrc;
2015       }
2016       elsif (defined $args->{foreign_values}) {
2017         $joinfree_alias = $args->{self_alias};
2018         $joinfree_source = $self;
2019       }
2020
2021       # FIXME sanity check until things stabilize, remove at some point
2022       $self->throw_exception (
2023         "A join-free condition returned for $exception_rel_id without a result object to chain from"
2024       ) unless $joinfree_alias;
2025
2026       my $fq_col_list = { map
2027         { ( "$joinfree_alias.$_" => 1 ) }
2028         $joinfree_source->columns
2029       };
2030
2031       exists $fq_col_list->{$_} or $self->throw_exception (
2032         "The join-free condition returned for $exception_rel_id may only "
2033       . 'contain keys that are fully qualified column names of the corresponding source '
2034       . "'$joinfree_alias' (instead it returned '$_')"
2035       ) for keys %$jfc;
2036
2037       (
2038         length ref $_
2039           and
2040         defined blessed($_)
2041           and
2042         $_->isa('DBIx::Class::Row')
2043           and
2044         $self->throw_exception (
2045           "The join-free condition returned for $exception_rel_id may not "
2046         . 'contain result objects as values - perhaps instead of invoking '
2047         . '->$something you meant to return ->get_column($something)'
2048         )
2049       ) for values %$jfc;
2050
2051     }
2052   }
2053   elsif (ref $rel_info->{cond} eq 'HASH') {
2054
2055     # the condition is static - use parallel arrays
2056     # for a "pivot" depending on which side of the
2057     # rel did we get as an object
2058     my (@f_cols, @l_cols);
2059     for my $fc (keys %{ $rel_info->{cond} }) {
2060       my $lc = $rel_info->{cond}{$fc};
2061
2062       # FIXME STRICTMODE should probably check these are valid columns
2063       $fc =~ s/^foreign\.// ||
2064         $self->throw_exception("Invalid rel cond key '$fc'");
2065
2066       $lc =~ s/^self\.// ||
2067         $self->throw_exception("Invalid rel cond val '$lc'");
2068
2069       push @f_cols, $fc;
2070       push @l_cols, $lc;
2071     }
2072
2073     # construct the crosstable condition and the identity map
2074     for  (0..$#f_cols) {
2075       $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" };
2076       $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_];
2077     };
2078
2079     if ($args->{foreign_values}) {
2080       $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]}
2081         for 0..$#f_cols;
2082     }
2083     elsif (defined $args->{self_result_object}) {
2084
2085       for my $i (0..$#l_cols) {
2086         if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) {
2087           $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]);
2088         }
2089         else {
2090           $self->throw_exception(sprintf
2091             "Unable to resolve relationship '%s' from object '%s': column '%s' not "
2092           . 'loaded from storage (or not passed to new() prior to insert()). You '
2093           . 'probably need to call ->discard_changes to get the server-side defaults '
2094           . 'from the database.',
2095             $args->{rel_name},
2096             $args->{self_result_object},
2097             $l_cols[$i],
2098           ) if $args->{self_result_object}->in_storage;
2099
2100           # FIXME - temporarly force-override
2101           delete $args->{require_join_free_condition};
2102           $ret->{join_free_condition} = UNRESOLVABLE_CONDITION;
2103           last;
2104         }
2105       }
2106     }
2107   }
2108   elsif (ref $rel_info->{cond} eq 'ARRAY') {
2109     if (@{ $rel_info->{cond} } == 0) {
2110       $ret = {
2111         condition => UNRESOLVABLE_CONDITION,
2112         join_free_condition => UNRESOLVABLE_CONDITION,
2113       };
2114     }
2115     else {
2116       my @subconds = map {
2117         local $rel_info->{cond} = $_;
2118         $self->_resolve_relationship_condition( $args );
2119       } @{ $rel_info->{cond} };
2120
2121       if( @{ $rel_info->{cond} } == 1 ) {
2122         $ret = $subconds[0];
2123       }
2124       else {
2125         # we are discarding inferred values here... likely incorrect...
2126         # then again - the entire thing is an OR, so we *can't* use them anyway
2127         for my $subcond ( @subconds ) {
2128           $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition')
2129             if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) );
2130
2131           $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition));
2132         }
2133       }
2134     }
2135   }
2136   else {
2137     $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :(");
2138   }
2139
2140   if (
2141     $args->{require_join_free_condition}
2142       and
2143     ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION )
2144   ) {
2145     $self->throw_exception(
2146       ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment",
2147         exists $args->{foreign_values}
2148           ? "'foreign_values'-based reversed-"
2149           : ''
2150     );
2151   }
2152
2153   # we got something back - sanity check and infer values if we can
2154   my @nonvalues;
2155   if (
2156     $ret->{join_free_condition}
2157       and
2158     $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION
2159       and
2160     my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} )
2161   ) {
2162
2163     my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls');
2164
2165     if (keys %$jfc_eqs) {
2166
2167       for (keys %$jfc) {
2168         # $jfc is fully qualified by definition
2169         my ($col) = $_ =~ /\.(.+)/;
2170
2171         if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) {
2172           $ret->{inferred_values}{$col} = $jfc_eqs->{$_};
2173         }
2174         elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) {
2175           push @nonvalues, $col;
2176         }
2177       }
2178
2179       # all or nothing
2180       delete $ret->{inferred_values} if @nonvalues;
2181     }
2182   }
2183
2184   # did the user explicitly ask
2185   if ($args->{infer_values_based_on}) {
2186
2187     $self->throw_exception(sprintf (
2188       "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s",
2189       map { "'$_'" } @nonvalues
2190     )) if @nonvalues;
2191
2192
2193     $ret->{inferred_values} ||= {};
2194
2195     $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_}
2196       for keys %{$args->{infer_values_based_on}};
2197   }
2198
2199   # add the identities based on the main condition
2200   # (may already be there, since easy to calculate on the fly in the HASH case)
2201   if ( ! $ret->{identity_map} ) {
2202
2203     my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition});
2204
2205     my $colinfos;
2206     for my $lhs (keys %$col_eqs) {
2207
2208       next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION;
2209
2210       # there is no way to know who is right and who is left in a cref
2211       # therefore a full blown resolution call, and figure out the
2212       # direction a bit further below
2213       $colinfos ||= $storage->_resolve_column_info([
2214         { -alias => $args->{self_alias}, -rsrc => $self },
2215         { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc },
2216       ]);
2217
2218       next unless $colinfos->{$lhs};  # someone is engaging in witchcraft
2219
2220       if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) {
2221
2222         if (
2223           $colinfos->{$rhs_ref->[0]}
2224             and
2225           $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias}
2226         ) {
2227           ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} )
2228             ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} )
2229             : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} )
2230           ;
2231         }
2232       }
2233       elsif (
2234         $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x
2235           and
2236         ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc
2237       ) {
2238         my ($lcol, $rcol) = map
2239           { $colinfos->{$_}{-colname} }
2240           ( $lhs, $1 )
2241         ;
2242         carp_unique(
2243           "The $exception_rel_id specifies equality of column '$lcol' and the "
2244         . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)"
2245         );
2246       }
2247     }
2248   }
2249
2250   # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition
2251   $ret->{condition} = { -and => [ $ret->{condition} ] }
2252     unless $ret->{condition} eq UNRESOLVABLE_CONDITION;
2253
2254   $ret;
2255 }
2256
2257 =head2 related_source
2258
2259 =over 4
2260
2261 =item Arguments: $rel_name
2262
2263 =item Return Value: $source
2264
2265 =back
2266
2267 Returns the result source object for the given relationship.
2268
2269 =cut
2270
2271 sub related_source {
2272   my ($self, $rel) = @_;
2273   if( !$self->has_relationship( $rel ) ) {
2274     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2275   }
2276
2277   # if we are not registered with a schema - just use the prototype
2278   # however if we do have a schema - ask for the source by name (and
2279   # throw in the process if all fails)
2280   if (my $schema = dbic_internal_try { $self->schema }) {
2281     $schema->source($self->relationship_info($rel)->{source});
2282   }
2283   else {
2284     my $class = $self->relationship_info($rel)->{class};
2285     $self->ensure_class_loaded($class);
2286     $class->result_source_instance;
2287   }
2288 }
2289
2290 =head2 related_class
2291
2292 =over 4
2293
2294 =item Arguments: $rel_name
2295
2296 =item Return Value: $classname
2297
2298 =back
2299
2300 Returns the class name for objects in the given relationship.
2301
2302 =cut
2303
2304 sub related_class {
2305   my ($self, $rel) = @_;
2306   if( !$self->has_relationship( $rel ) ) {
2307     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
2308   }
2309   return $self->schema->class($self->relationship_info($rel)->{source});
2310 }
2311
2312 =head2 handle
2313
2314 =over 4
2315
2316 =item Arguments: none
2317
2318 =item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle>
2319
2320 =back
2321
2322 Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
2323 for this source. Used as a serializable pointer to this resultsource, as it is not
2324 easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
2325 relationship definitions.
2326
2327 =cut
2328
2329 sub handle {
2330   require DBIx::Class::ResultSourceHandle;
2331   return DBIx::Class::ResultSourceHandle->new({
2332     source_moniker => $_[0]->source_name,
2333
2334     # so that a detached thaw can be re-frozen
2335     $_[0]->{_detached_thaw}
2336       ? ( _detached_source  => $_[0]          )
2337       : ( schema            => $_[0]->schema  )
2338     ,
2339   });
2340 }
2341
2342 my $global_phase_destroy;
2343 sub DESTROY {
2344   ### NO detected_reinvoked_destructor check
2345   ### This code very much relies on being called multuple times
2346
2347   return if $global_phase_destroy ||= in_global_destruction;
2348
2349 ######
2350 # !!! ACHTUNG !!!!
2351 ######
2352 #
2353 # Under no circumstances shall $_[0] be stored anywhere else (like copied to
2354 # a lexical variable, or shifted, or anything else). Doing so will mess up
2355 # the refcount of this particular result source, and will allow the $schema
2356 # we are trying to save to reattach back to the source we are destroying.
2357 # The relevant code checking refcounts is in ::Schema::DESTROY()
2358
2359   # if we are not a schema instance holder - we don't matter
2360   return if(
2361     ! ref $_[0]->{schema}
2362       or
2363     isweak $_[0]->{schema}
2364   );
2365
2366   # weaken our schema hold forcing the schema to find somewhere else to live
2367   # during global destruction (if we have not yet bailed out) this will throw
2368   # which will serve as a signal to not try doing anything else
2369   # however beware - on older perls the exception seems randomly untrappable
2370   # due to some weird race condition during thread joining :(((
2371   local $SIG{__DIE__} if $SIG{__DIE__};
2372   local $@;
2373   eval {
2374     weaken $_[0]->{schema};
2375
2376     # if schema is still there reintroduce ourselves with strong refs back to us
2377     if ($_[0]->{schema}) {
2378       my $srcregs = $_[0]->{schema}->source_registrations;
2379
2380       defined $srcregs->{$_}
2381         and
2382       $srcregs->{$_} == $_[0]
2383         and
2384       $srcregs->{$_} = $_[0]
2385         and
2386       last
2387         for keys %$srcregs;
2388     }
2389
2390     1;
2391   } or do {
2392     $global_phase_destroy = 1;
2393   };
2394
2395   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
2396   # collected before leaving this scope. Depending on the code above, this
2397   # may very well be just a preventive measure guarding future modifications
2398   undef;
2399 }
2400
2401 sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
2402
2403 sub STORABLE_thaw {
2404   my ($self, $cloning, $ice) = @_;
2405   %$self = %{ (Storable::thaw($ice))->resolve };
2406 }
2407
2408 =head2 throw_exception
2409
2410 See L<DBIx::Class::Schema/"throw_exception">.
2411
2412 =cut
2413
2414 sub throw_exception {
2415   my $self = shift;
2416
2417   $self->{schema}
2418     ? $self->{schema}->throw_exception(@_)
2419     : DBIx::Class::Exception->throw(@_)
2420   ;
2421 }
2422
2423 =head2 column_info_from_storage
2424
2425 =over
2426
2427 =item Arguments: 1/0 (default: 0)
2428
2429 =item Return Value: 1/0
2430
2431 =back
2432
2433   __PACKAGE__->column_info_from_storage(1);
2434
2435 Enables the on-demand automatic loading of the above column
2436 metadata from storage as necessary.  This is *deprecated*, and
2437 should not be used.  It will be removed before 1.0.
2438
2439 =head1 FURTHER QUESTIONS?
2440
2441 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
2442
2443 =head1 COPYRIGHT AND LICENSE
2444
2445 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
2446 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
2447 redistribute it and/or modify it under the same terms as the
2448 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
2449
2450 =cut
2451
2452 1;