lib/DBIx/Class/ResultSource.pm

   1 package DBIx::Class::ResultSource;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::ResultSet;
   7 use DBIx::Class::ResultSourceHandle;
   8 use Carp::Clan qw/^DBIx::Class/;
   9 use Storable;
  10
  11 use base qw/DBIx::Class/;
  12
  13 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
  14   _columns _primaries _unique_constraints name resultset_attributes
  15   schema from _relationships column_info_from_storage source_info
  16   source_name/);
  17
  18 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
  19   result_class/);
  20
  21 =head1 NAME
  22
  23 DBIx::Class::ResultSource - Result source object
  24
  25 =head1 SYNOPSIS
  26
  27 =head1 DESCRIPTION
  28
  29 A ResultSource is a component of a schema from which results can be directly
  30 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
  31
  32 =head1 METHODS
  33
  34 =pod
  35
  36 =head2 new
  37
  38   $class->new();
  39
  40   $class->new({attribute_name => value});
  41
  42 Creates a new ResultSource object.  Not normally called directly by end users.
  43
  44 =cut
  45
  46 sub new {
  47   my ($class, $attrs) = @_;
  48   $class = ref $class if ref $class;
  49
  50   my $new = bless { %{$attrs || {}} }, $class;
  51   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  52   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  53   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  54   $new->{_columns} = { %{$new->{_columns}||{}} };
  55   $new->{_relationships} = { %{$new->{_relationships}||{}} };
  56   $new->{name} ||= "!!NAME NOT SET!!";
  57   $new->{_columns_info_loaded} ||= 0;
  58   return $new;
  59 }
  60
  61 =pod
  62
  63 =head2 source_info
  64
  65 Stores a hashref of per-source metadata.  No specific key names
  66 have yet been standardized, the examples below are purely hypothetical
  67 and don't actually accomplish anything on their own:
  68
  69   __PACKAGE__->source_info({
  70     "_tablespace" => 'fast_disk_array_3',
  71     "_engine" => 'InnoDB',
  72   });
  73
  74 =head2 add_columns
  75
  76   $table->add_columns(qw/col1 col2 col3/);
  77
  78   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  79
  80 Adds columns to the result source. If supplied key => hashref pairs, uses
  81 the hashref as the column_info for that column. Repeated calls of this
  82 method will add more columns, not replace them.
  83
  84 The column names given will be created as accessor methods on your
  85 L<DBIx::Class::Row> objects, you can change the name of the accessor
  86 by supplying an L</accessor> in the column_info hash.
  87
  88 The contents of the column_info are not set in stone. The following
  89 keys are currently recognised/used by DBIx::Class:
  90
  91 =over 4
  92
  93 =item accessor
  94
  95 Use this to set the name of the accessor method for this column. If unset,
  96 the name of the column will be used.
  97
  98 =item data_type
  99
 100 This contains the column type. It is automatically filled by the
 101 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
 102 L<DBIx::Class::Schema::Loader> module. If you do not enter a
 103 data_type, DBIx::Class will attempt to retrieve it from the
 104 database for you, using L<DBI>'s column_info method. The values of this
 105 key are typically upper-cased.
 106
 107 Currently there is no standard set of values for the data_type. Use
 108 whatever your database supports.
 109
 110 =item size
 111
 112 The length of your column, if it is a column type that can have a size
 113 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
 114
 115 =item is_nullable
 116
 117 Set this to a true value for a columns that is allowed to contain
 118 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
 119
 120 =item is_auto_increment
 121
 122 Set this to a true value for a column whose value is somehow
 123 automatically set. This is used to determine which columns to empty
 124 when cloning objects using C<copy>. It is also used by
 125 L<DBIx::Class::Schema/deploy>.
 126
 127 =item is_foreign_key
 128
 129 Set this to a true value for a column that contains a key from a
 130 foreign table. This is currently only used by
 131 L<DBIx::Class::Schema/deploy>.
 132
 133 =item default_value
 134
 135 Set this to the default value which will be inserted into a column
 136 by the database. Can contain either a value or a function. This is
 137 currently only used by L<DBIx::Class::Schema/deploy>.
 138
 139 =item sequence
 140
 141 Set this on a primary key column to the name of the sequence used to
 142 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
 143 will attempt to retrieve the name of the sequence from the database
 144 automatically.
 145
 146 =item auto_nextval
 147
 148 Set this to a true value for a column whose value is retrieved
 149 automatically from an oracle sequence. If you do not use an oracle
 150 trigger to get the nextval, you have to set sequence as well.
 151
 152 =item extra
 153
 154 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
 155 to add extra non-generic data to the column. For example: C<< extra
 156 => { unsigned => 1} >> is used by the MySQL producer to set an integer
 157 column to unsigned. For more details, see
 158 L<SQL::Translator::Producer::MySQL>.
 159
 160 =back
 161
 162 =head2 add_column
 163
 164   $table->add_column('col' => \%info?);
 165
 166 Convenience alias to add_columns.
 167
 168 =cut
 169
 170 sub add_columns {
 171   my ($self, @cols) = @_;
 172   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
 173
 174   my @added;
 175   my $columns = $self->_columns;
 176   while (my $col = shift @cols) {
 177     # If next entry is { ... } use that for the column info, if not
 178     # use an empty hashref
 179     my $column_info = ref $cols[0] ? shift(@cols) : {};
 180     push(@added, $col) unless exists $columns->{$col};
 181     $columns->{$col} = $column_info;
 182   }
 183   push @{ $self->_ordered_columns }, @added;
 184   return $self;
 185 }
 186
 187 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 188
 189 =head2 has_column
 190
 191   if ($obj->has_column($col)) { ... }
 192
 193 Returns true if the source has a column of this name, false otherwise.
 194
 195 =cut
 196
 197 sub has_column {
 198   my ($self, $column) = @_;
 199   return exists $self->_columns->{$column};
 200 }
 201
 202 =head2 column_info
 203
 204   my $info = $obj->column_info($col);
 205
 206 Returns the column metadata hashref for a column. See the description
 207 of add_column for information on the contents of the hashref.
 208
 209 =cut
 210
 211 sub column_info {
 212   my ($self, $column) = @_;
 213   $self->throw_exception("No such column $column")
 214     unless exists $self->_columns->{$column};
 215   #warn $self->{_columns_info_loaded}, "\n";
 216   if ( ! $self->_columns->{$column}{data_type}
 217        and $self->column_info_from_storage
 218        and ! $self->{_columns_info_loaded}
 219        and $self->schema and $self->storage )
 220   {
 221     $self->{_columns_info_loaded}++;
 222     my $info = {};
 223     my $lc_info = {};
 224     # eval for the case of storage without table
 225     eval { $info = $self->storage->columns_info_for( $self->from ) };
 226     unless ($@) {
 227       for my $realcol ( keys %{$info} ) {
 228         $lc_info->{lc $realcol} = $info->{$realcol};
 229       }
 230       foreach my $col ( keys %{$self->_columns} ) {
 231         $self->_columns->{$col} = {
 232           %{ $self->_columns->{$col} },
 233           %{ $info->{$col} || $lc_info->{lc $col} || {} }
 234         };
 235       }
 236     }
 237   }
 238   return $self->_columns->{$column};
 239 }
 240
 241 =head2 column_info_from_storage
 242
 243 Enables the on-demand automatic loading of the above column
 244 metadata from storage as neccesary.  This is *deprecated*, and
 245 should not be used.  It will be removed before 1.0.
 246
 247   __PACKAGE__->column_info_from_storage(1);
 248
 249 =head2 columns
 250
 251   my @column_names = $obj->columns;
 252
 253 Returns all column names in the order they were declared to add_columns.
 254
 255 =cut
 256
 257 sub columns {
 258   my $self = shift;
 259   $self->throw_exception(
 260     "columns() is a read-only accessor, did you mean add_columns()?"
 261   ) if (@_ > 1);
 262   return @{$self->{_ordered_columns}||[]};
 263 }
 264
 265 =head2 remove_columns
 266
 267   $table->remove_columns(qw/col1 col2 col3/);
 268
 269 Removes columns from the result source.
 270
 271 =head2 remove_column
 272
 273   $table->remove_column('col');
 274
 275 Convenience alias to remove_columns.
 276
 277 =cut
 278
 279 sub remove_columns {
 280   my ($self, @cols) = @_;
 281
 282   return unless $self->_ordered_columns;
 283
 284   my $columns = $self->_columns;
 285   my @remaining;
 286
 287   foreach my $col (@{$self->_ordered_columns}) {
 288     push @remaining, $col unless grep(/$col/, @cols);
 289   }
 290
 291   foreach (@cols) {
 292     delete $columns->{$_};
 293   };
 294
 295   $self->_ordered_columns(\@remaining);
 296 }
 297
 298 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 299
 300 =head2 set_primary_key
 301
 302 =over 4
 303
 304 =item Arguments: @cols
 305
 306 =back
 307
 308 Defines one or more columns as primary key for this source. Should be
 309 called after C<add_columns>.
 310
 311 Additionally, defines a unique constraint named C<primary>.
 312
 313 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 314 retrieve automatically created values from the database.
 315
 316 =cut
 317
 318 sub set_primary_key {
 319   my ($self, @cols) = @_;
 320   # check if primary key columns are valid columns
 321   foreach my $col (@cols) {
 322     $self->throw_exception("No such column $col on table " . $self->name)
 323       unless $self->has_column($col);
 324   }
 325   $self->_primaries(\@cols);
 326
 327   $self->add_unique_constraint(primary => \@cols);
 328 }
 329
 330 =head2 primary_columns
 331
 332 Read-only accessor which returns the list of primary keys.
 333
 334 =cut
 335
 336 sub primary_columns {
 337   return @{shift->_primaries||[]};
 338 }
 339
 340 =head2 add_unique_constraint
 341
 342 Declare a unique constraint on this source. Call once for each unique
 343 constraint.
 344
 345   # For UNIQUE (column1, column2)
 346   __PACKAGE__->add_unique_constraint(
 347     constraint_name => [ qw/column1 column2/ ],
 348   );
 349
 350 Alternatively, you can specify only the columns:
 351
 352   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
 353
 354 This will result in a unique constraint named C<table_column1_column2>, where
 355 C<table> is replaced with the table name.
 356
 357 Unique constraints are used, for example, when you call
 358 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
 359
 360 =cut
 361
 362 sub add_unique_constraint {
 363   my $self = shift;
 364   my $cols = pop @_;
 365   my $name = shift;
 366
 367   $name ||= $self->name_unique_constraint($cols);
 368
 369   foreach my $col (@$cols) {
 370     $self->throw_exception("No such column $col on table " . $self->name)
 371       unless $self->has_column($col);
 372   }
 373
 374   my %unique_constraints = $self->unique_constraints;
 375   $unique_constraints{$name} = $cols;
 376   $self->_unique_constraints(\%unique_constraints);
 377 }
 378
 379 =head2 name_unique_constraint
 380
 381 Return a name for a unique constraint containing the specified columns. These
 382 names consist of the table name and each column name, separated by underscores.
 383
 384 For example, a constraint on a table named C<cd> containing the columns
 385 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 386
 387 =cut
 388
 389 sub name_unique_constraint {
 390   my ($self, $cols) = @_;
 391
 392   return join '_', $self->name, @$cols;
 393 }
 394
 395 =head2 unique_constraints
 396
 397 Read-only accessor which returns the list of unique constraints on this source.
 398
 399 =cut
 400
 401 sub unique_constraints {
 402   return %{shift->_unique_constraints||{}};
 403 }
 404
 405 =head2 unique_constraint_names
 406
 407 Returns the list of unique constraint names defined on this source.
 408
 409 =cut
 410
 411 sub unique_constraint_names {
 412   my ($self) = @_;
 413
 414   my %unique_constraints = $self->unique_constraints;
 415
 416   return keys %unique_constraints;
 417 }
 418
 419 =head2 unique_constraint_columns
 420
 421 Returns the list of columns that make up the specified unique constraint.
 422
 423 =cut
 424
 425 sub unique_constraint_columns {
 426   my ($self, $constraint_name) = @_;
 427
 428   my %unique_constraints = $self->unique_constraints;
 429
 430   $self->throw_exception(
 431     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 432   ) unless exists $unique_constraints{$constraint_name};
 433
 434   return @{ $unique_constraints{$constraint_name} };
 435 }
 436
 437 =head2 from
 438
 439 Returns an expression of the source to be supplied to storage to specify
 440 retrieval from this source. In the case of a database, the required FROM
 441 clause contents.
 442
 443 =head2 schema
 444
 445 Returns the L<DBIx::Class::Schema> object that this result source
 446 belongs too.
 447
 448 =head2 storage
 449
 450 Returns the storage handle for the current schema.
 451
 452 See also: L<DBIx::Class::Storage>
 453
 454 =cut
 455
 456 sub storage { shift->schema->storage; }
 457
 458 =head2 add_relationship
 459
 460   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 461
 462 The relationship name can be arbitrary, but must be unique for each
 463 relationship attached to this result source. 'related_source' should
 464 be the name with which the related result source was registered with
 465 the current schema. For example:
 466
 467   $schema->source('Book')->add_relationship('reviews', 'Review', {
 468     'foreign.book_id' => 'self.id',
 469   });
 470
 471 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 472 representation of the join between the tables. For example, if you're
 473 creating a rel from Author to Book,
 474
 475   { 'foreign.author_id' => 'self.id' }
 476
 477 will result in the JOIN clause
 478
 479   author me JOIN book foreign ON foreign.author_id = me.id
 480
 481 You can specify as many foreign => self mappings as necessary.
 482
 483 Valid attributes are as follows:
 484
 485 =over 4
 486
 487 =item join_type
 488
 489 Explicitly specifies the type of join to use in the relationship. Any
 490 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 491 the SQL command immediately before C<JOIN>.
 492
 493 =item proxy
 494
 495 An arrayref containing a list of accessors in the foreign class to proxy in
 496 the main class. If, for example, you do the following:
 497
 498   CD->might_have(liner_notes => 'LinerNotes', undef, {
 499     proxy => [ qw/notes/ ],
 500   });
 501
 502 Then, assuming LinerNotes has an accessor named notes, you can do:
 503
 504   my $cd = CD->find(1);
 505   # set notes -- LinerNotes object is created if it doesn't exist
 506   $cd->notes('Notes go here');
 507
 508 =item accessor
 509
 510 Specifies the type of accessor that should be created for the
 511 relationship. Valid values are C<single> (for when there is only a single
 512 related object), C<multi> (when there can be many), and C<filter> (for
 513 when there is a single related object, but you also want the relationship
 514 accessor to double as a column accessor). For C<multi> accessors, an
 515 add_to_* method is also created, which calls C<create_related> for the
 516 relationship.
 517
 518 =back
 519
 520 =cut
 521
 522 sub add_relationship {
 523   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 524   $self->throw_exception("Can't create relationship without join condition")
 525     unless $cond;
 526   $attrs ||= {};
 527
 528   # Check foreign and self are right in cond
 529   if ( (ref $cond ||'') eq 'HASH') {
 530     for (keys %$cond) {
 531       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
 532         if /\./ && !/^foreign\./;
 533     }
 534   }
 535
 536   my %rels = %{ $self->_relationships };
 537   $rels{$rel} = { class => $f_source_name,
 538                   source => $f_source_name,
 539                   cond  => $cond,
 540                   attrs => $attrs };
 541   $self->_relationships(\%rels);
 542
 543   return $self;
 544
 545   # XXX disabled. doesn't work properly currently. skip in tests.
 546
 547   my $f_source = $self->schema->source($f_source_name);
 548   unless ($f_source) {
 549     $self->ensure_class_loaded($f_source_name);
 550     $f_source = $f_source_name->result_source;
 551     #my $s_class = ref($self->schema);
 552     #$f_source_name =~ m/^${s_class}::(.*)$/;
 553     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 554     #$f_source = $self->schema->source($f_source_name);
 555   }
 556   return unless $f_source; # Can't test rel without f_source
 557
 558   eval { $self->resolve_join($rel, 'me') };
 559
 560   if ($@) { # If the resolve failed, back out and re-throw the error
 561     delete $rels{$rel}; #
 562     $self->_relationships(\%rels);
 563     $self->throw_exception("Error creating relationship $rel: $@");
 564   }
 565   1;
 566 }
 567
 568 =head2 relationships
 569
 570 Returns all relationship names for this source.
 571
 572 =cut
 573
 574 sub relationships {
 575   return keys %{shift->_relationships};
 576 }
 577
 578 =head2 relationship_info
 579
 580 =over 4
 581
 582 =item Arguments: $relname
 583
 584 =back
 585
 586 Returns a hash of relationship information for the specified relationship
 587 name.
 588
 589 =cut
 590
 591 sub relationship_info {
 592   my ($self, $rel) = @_;
 593   return $self->_relationships->{$rel};
 594 }
 595
 596 =head2 has_relationship
 597
 598 =over 4
 599
 600 =item Arguments: $rel
 601
 602 =back
 603
 604 Returns true if the source has a relationship of this name, false otherwise.
 605
 606 =cut
 607
 608 sub has_relationship {
 609   my ($self, $rel) = @_;
 610   return exists $self->_relationships->{$rel};
 611 }
 612
 613 =head2 reverse_relationship_info
 614
 615 =over 4
 616
 617 =item Arguments: $relname
 618
 619 =back
 620
 621 Returns an array of hash references of relationship information for
 622 the other side of the specified relationship name.
 623
 624 =cut
 625
 626 sub reverse_relationship_info {
 627   my ($self, $rel) = @_;
 628   my $rel_info = $self->relationship_info($rel);
 629   my $ret = {};
 630
 631   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 632
 633   my @cond = keys(%{$rel_info->{cond}});
 634   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
 635   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
 636
 637   # Get the related result source for this relationship
 638   my $othertable = $self->related_source($rel);
 639
 640   # Get all the relationships for that source that related to this source
 641   # whose foreign column set are our self columns on $rel and whose self
 642   # columns are our foreign columns on $rel.
 643   my @otherrels = $othertable->relationships();
 644   my $otherrelationship;
 645   foreach my $otherrel (@otherrels) {
 646     my $otherrel_info = $othertable->relationship_info($otherrel);
 647
 648     my $back = $othertable->related_source($otherrel);
 649     next unless $back->source_name eq $self->source_name;
 650
 651     my @othertestconds;
 652
 653     if (ref $otherrel_info->{cond} eq 'HASH') {
 654       @othertestconds = ($otherrel_info->{cond});
 655     }
 656     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
 657       @othertestconds = @{$otherrel_info->{cond}};
 658     }
 659     else {
 660       next;
 661     }
 662
 663     foreach my $othercond (@othertestconds) {
 664       my @other_cond = keys(%$othercond);
 665       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
 666       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
 667       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
 668                !$self->compare_relationship_keys(\@other_refkeys, \@keys));
 669       $ret->{$otherrel} =  $otherrel_info;
 670     }
 671   }
 672   return $ret;
 673 }
 674
 675 =head2 compare_relationship_keys
 676
 677 =over 4
 678
 679 =item Arguments: $keys1, $keys2
 680
 681 =back
 682
 683 Returns true if both sets of keynames are the same, false otherwise.
 684
 685 =cut
 686
 687 sub compare_relationship_keys {
 688   my ($self, $keys1, $keys2) = @_;
 689
 690   # Make sure every keys1 is in keys2
 691   my $found;
 692   foreach my $key (@$keys1) {
 693     $found = 0;
 694     foreach my $prim (@$keys2) {
 695       if ($prim eq $key) {
 696         $found = 1;
 697         last;
 698       }
 699     }
 700     last unless $found;
 701   }
 702
 703   # Make sure every key2 is in key1
 704   if ($found) {
 705     foreach my $prim (@$keys2) {
 706       $found = 0;
 707       foreach my $key (@$keys1) {
 708         if ($prim eq $key) {
 709           $found = 1;
 710           last;
 711         }
 712       }
 713       last unless $found;
 714     }
 715   }
 716
 717   return $found;
 718 }
 719
 720 =head2 resolve_join
 721
 722 =over 4
 723
 724 =item Arguments: $relation
 725
 726 =back
 727
 728 Returns the join structure required for the related result source.
 729
 730 =cut
 731
 732 sub resolve_join {
 733   my ($self, $join, $alias, $seen, $force_left) = @_;
 734   $seen ||= {};
 735   $force_left ||= { force => 0 };
 736   if (ref $join eq 'ARRAY') {
 737     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 738   } elsif (ref $join eq 'HASH') {
 739     return
 740       map {
 741         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 742         local $force_left->{force};
 743         (
 744           $self->resolve_join($_, $alias, $seen, $force_left),
 745           $self->related_source($_)->resolve_join(
 746             $join->{$_}, $as, $seen, $force_left
 747           )
 748         );
 749       } keys %$join;
 750   } elsif (ref $join) {
 751     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 752   } else {
 753     my $count = ++$seen->{$join};
 754     #use Data::Dumper; warn Dumper($seen);
 755     my $as = ($count > 1 ? "${join}_${count}" : $join);
 756     my $rel_info = $self->relationship_info($join);
 757     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 758     my $type;
 759     if ($force_left->{force}) {
 760       $type = 'left';
 761     } else {
 762       $type = $rel_info->{attrs}{join_type} || '';
 763       $force_left->{force} = 1 if lc($type) eq 'left';
 764     }
 765     return [ { $as => $self->related_source($join)->from,
 766                -join_type => $type },
 767              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 768   }
 769 }
 770
 771 =head2 pk_depends_on
 772
 773 =over 4
 774
 775 =item Arguments: $relname, $rel_data
 776
 777 =back
 778
 779 Determines whether a relation is dependent on an object from this source
 780 having already been inserted. Takes the name of the relationship and a
 781 hashref of columns of the related object.
 782
 783 =cut
 784
 785 sub pk_depends_on {
 786   my ($self, $relname, $rel_data) = @_;
 787   my $cond = $self->relationship_info($relname)->{cond};
 788
 789   return 0 unless ref($cond) eq 'HASH';
 790
 791   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
 792
 793   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
 794
 795   # assume anything that references our PK probably is dependent on us
 796   # rather than vice versa, unless the far side is (a) defined or (b)
 797   # auto-increment
 798
 799   my $rel_source = $self->related_source($relname);
 800
 801   foreach my $p ($self->primary_columns) {
 802     if (exists $keyhash->{$p}) {
 803       unless (defined($rel_data->{$keyhash->{$p}})
 804               || $rel_source->column_info($keyhash->{$p})
 805                             ->{is_auto_increment}) {
 806         return 0;
 807       }
 808     }
 809   }
 810
 811   return 1;
 812 }
 813
 814 =head2 resolve_condition
 815
 816 =over 4
 817
 818 =item Arguments: $cond, $as, $alias|$object
 819
 820 =back
 821
 822 Resolves the passed condition to a concrete query fragment. If given an alias,
 823 returns a join condition; if given an object, inverts that object to produce
 824 a related conditional from that object.
 825
 826 =cut
 827
 828 our $UNRESOLVABLE_CONDITION = \'1 = 0';
 829
 830 sub resolve_condition {
 831   my ($self, $cond, $as, $for) = @_;
 832   #warn %$cond;
 833   if (ref $cond eq 'HASH') {
 834     my %ret;
 835     foreach my $k (keys %{$cond}) {
 836       my $v = $cond->{$k};
 837       # XXX should probably check these are valid columns
 838       $k =~ s/^foreign\.// ||
 839         $self->throw_exception("Invalid rel cond key ${k}");
 840       $v =~ s/^self\.// ||
 841         $self->throw_exception("Invalid rel cond val ${v}");
 842       if (ref $for) { # Object
 843         #warn "$self $k $for $v";
 844         unless ($for->has_column_loaded($v)) {
 845           if ($for->in_storage) {
 846             $self->throw_exception("Column ${v} not loaded on ${for} trying to reolve relationship");
 847           }
 848           return $UNRESOLVABLE_CONDITION;
 849         }
 850         $ret{$k} = $for->get_column($v);
 851         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
 852         #warn %ret;
 853       } elsif (!defined $for) { # undef, i.e. "no object"
 854         $ret{$k} = undef;
 855       } elsif (ref $as eq 'HASH') { # reverse hashref
 856         $ret{$v} = $as->{$k};
 857       } elsif (ref $as) { # reverse object
 858         $ret{$v} = $as->get_column($k);
 859       } elsif (!defined $as) { # undef, i.e. "no reverse object"
 860         $ret{$v} = undef;
 861       } else {
 862         $ret{"${as}.${k}"} = "${for}.${v}";
 863       }
 864     }
 865     return \%ret;
 866   } elsif (ref $cond eq 'ARRAY') {
 867     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 868   } else {
 869    die("Can't handle this yet :(");
 870   }
 871 }
 872
 873 =head2 resolve_prefetch
 874
 875 =over 4
 876
 877 =item Arguments: hashref/arrayref/scalar
 878
 879 =back
 880
 881 Accepts one or more relationships for the current source and returns an
 882 array of column names for each of those relationships. Column names are
 883 prefixed relative to the current source, in accordance with where they appear
 884 in the supplied relationships. Examples:
 885
 886   my $source = $schema->resultset('Tag')->source;
 887   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 888
 889   # @columns =
 890   #(
 891   #  'cd.cdid',
 892   #  'cd.artist',
 893   #  'cd.title',
 894   #  'cd.year',
 895   #  'cd.artist.artistid',
 896   #  'cd.artist.name'
 897   #)
 898
 899   @columns = $source->resolve_prefetch( qw[/ cd /] );
 900
 901   # @columns =
 902   #(
 903   #   'cd.cdid',
 904   #   'cd.artist',
 905   #   'cd.title',
 906   #   'cd.year'
 907   #)
 908
 909   $source = $schema->resultset('CD')->source;
 910   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 911
 912   # @columns =
 913   #(
 914   #  'artist.artistid',
 915   #  'artist.name',
 916   #  'producer.producerid',
 917   #  'producer.name'
 918   #)
 919
 920 =cut
 921
 922 sub resolve_prefetch {
 923   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 924   $seen ||= {};
 925   #$alias ||= $self->name;
 926   #warn $alias, Dumper $pre;
 927   if( ref $pre eq 'ARRAY' ) {
 928     return
 929       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 930         @$pre;
 931   }
 932   elsif( ref $pre eq 'HASH' ) {
 933     my @ret =
 934     map {
 935       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 936       $self->related_source($_)->resolve_prefetch(
 937                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 938     } keys %$pre;
 939     #die Dumper \@ret;
 940     return @ret;
 941   }
 942   elsif( ref $pre ) {
 943     $self->throw_exception(
 944       "don't know how to resolve prefetch reftype ".ref($pre));
 945   }
 946   else {
 947     my $count = ++$seen->{$pre};
 948     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 949     my $rel_info = $self->relationship_info( $pre );
 950     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 951       unless $rel_info;
 952     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 953     my $rel_source = $self->related_source($pre);
 954
 955     if (exists $rel_info->{attrs}{accessor}
 956          && $rel_info->{attrs}{accessor} eq 'multi') {
 957       $self->throw_exception(
 958         "Can't prefetch has_many ${pre} (join cond too complex)")
 959         unless ref($rel_info->{cond}) eq 'HASH';
 960       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
 961       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
 962                          keys %{$collapse}) {
 963         my ($last) = ($fail =~ /([^\.]+)$/);
 964         $self->throw_exception(
 965           "Can't prefetch multiple has_many rels ${last} and ${pre}"
 966           .(length($as_prefix) ? "at the same level (${as_prefix})"
 967                                : "at top level"
 968         ));
 969       }
 970       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
 971       #              values %{$rel_info->{cond}};
 972       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
 973         # action at a distance. prepending the '.' allows simpler code
 974         # in ResultSet->_collapse_result
 975       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 976                     keys %{$rel_info->{cond}};
 977       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 978                    ? @{$rel_info->{attrs}{order_by}}
 979                    : (defined $rel_info->{attrs}{order_by}
 980                        ? ($rel_info->{attrs}{order_by})
 981                        : ()));
 982       push(@$order, map { "${as}.$_" } (@key, @ord));
 983     }
 984
 985     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 986       $rel_source->columns;
 987     #warn $alias, Dumper (\@ret);
 988     #return @ret;
 989   }
 990 }
 991
 992 =head2 related_source
 993
 994 =over 4
 995
 996 =item Arguments: $relname
 997
 998 =back
 999
1000 Returns the result source object for the given relationship.
1001
1002 =cut
1003
1004 sub related_source {
1005   my ($self, $rel) = @_;
1006   if( !$self->has_relationship( $rel ) ) {
1007     $self->throw_exception("No such relationship '$rel'");
1008   }
1009   return $self->schema->source($self->relationship_info($rel)->{source});
1010 }
1011
1012 =head2 related_class
1013
1014 =over 4
1015
1016 =item Arguments: $relname
1017
1018 =back
1019
1020 Returns the class name for objects in the given relationship.
1021
1022 =cut
1023
1024 sub related_class {
1025   my ($self, $rel) = @_;
1026   if( !$self->has_relationship( $rel ) ) {
1027     $self->throw_exception("No such relationship '$rel'");
1028   }
1029   return $self->schema->class($self->relationship_info($rel)->{source});
1030 }
1031
1032 =head2 resultset
1033
1034 Returns a resultset for the given source. This will initially be created
1035 on demand by calling
1036
1037   $self->resultset_class->new($self, $self->resultset_attributes)
1038
1039 but is cached from then on unless resultset_class changes.
1040
1041 =head2 resultset_class
1042
1043 ` package My::ResultSetClass;
1044   use base 'DBIx::Class::ResultSet';
1045   ...
1046
1047   $source->resultset_class('My::ResultSet::Class');
1048
1049 Set the class of the resultset, this is useful if you want to create your
1050 own resultset methods. Create your own class derived from
1051 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1052 this method returns the name of the existing resultset class, if one
1053 exists.
1054
1055 =head2 resultset_attributes
1056
1057   $source->resultset_attributes({ order_by => [ 'id' ] });
1058
1059 Specify here any attributes you wish to pass to your specialised
1060 resultset. For a full list of these, please see
1061 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1062
1063 =cut
1064
1065 sub resultset {
1066   my $self = shift;
1067   $self->throw_exception(
1068     'resultset does not take any arguments. If you want another resultset, '.
1069     'call it on the schema instead.'
1070   ) if scalar @_;
1071
1072   return $self->resultset_class->new(
1073     $self,
1074     {
1075       %{$self->{resultset_attributes}},
1076       %{$self->schema->default_resultset_attributes}
1077     },
1078   );
1079 }
1080
1081 =head2 source_name
1082
1083 =over 4
1084
1085 =item Arguments: $source_name
1086
1087 =back
1088
1089 Set the name of the result source when it is loaded into a schema.
1090 This is usefull if you want to refer to a result source by a name other than
1091 its class name.
1092
1093   package ArchivedBooks;
1094   use base qw/DBIx::Class/;
1095   __PACKAGE__->table('books_archive');
1096   __PACKAGE__->source_name('Books');
1097
1098   # from your schema...
1099   $schema->resultset('Books')->find(1);
1100
1101 =head2 handle
1102
1103 Obtain a new handle to this source. Returns an instance of a
1104 L<DBIx::Class::ResultSourceHandle>.
1105
1106 =cut
1107
1108 sub handle {
1109     return new DBIx::Class::ResultSourceHandle({
1110         schema         => $_[0]->schema,
1111         source_moniker => $_[0]->source_name
1112     });
1113 }
1114
1115 =head2 throw_exception
1116
1117 See L<DBIx::Class::Schema/"throw_exception">.
1118
1119 =cut
1120
1121 sub throw_exception {
1122   my $self = shift;
1123   if (defined $self->schema) {
1124     $self->schema->throw_exception(@_);
1125   } else {
1126     croak(@_);
1127   }
1128 }
1129
1130 =head2 sqlt_deploy_hook($sqlt_table)
1131
1132 An optional sub which you can declare in your own Schema class that will get
1133 passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1134 via L</create_ddl_dir> or L</deploy>.
1135
1136 For an example of what you can do with this, see
1137 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1138
1139 =head1 AUTHORS
1140
1141 Matt S. Trout <mst@shadowcatsystems.co.uk>
1142
1143 =head1 LICENSE
1144
1145 You may distribute this code under the same terms as Perl itself.
1146
1147 =cut
1148
1149 1;