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