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