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