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