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