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