lib/DBIx/Class/ResultSource.pm

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