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