lib/DBIx/Class/ResultSource.pm

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