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