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