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