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