lib/DBIx/Class/ResultSource.pm

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