lib/DBIx/Class/ResultSource.pm

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