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