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