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     eval "require $f_source_name;";
 460     if ($@) {
 461       die $@ unless $@ =~ /Can't locate/;
 462     }
 463     $f_source = $f_source_name->result_source;
 464     #my $s_class = ref($self->schema);
 465     #$f_source_name =~ m/^${s_class}::(.*)$/;
 466     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 467     #$f_source = $self->schema->source($f_source_name);
 468   }
 469   return unless $f_source; # Can't test rel without f_source
 470
 471   eval { $self->resolve_join($rel, 'me') };
 472
 473   if ($@) { # If the resolve failed, back out and re-throw the error
 474     delete $rels{$rel}; #
 475     $self->_relationships(\%rels);
 476     $self->throw_exception("Error creating relationship $rel: $@");
 477   }
 478   1;
 479 }
 480
 481 =head2 relationships
 482
 483 Returns all relationship names for this source.
 484
 485 =cut
 486
 487 sub relationships {
 488   return keys %{shift->_relationships};
 489 }
 490
 491 =head2 relationship_info
 492
 493 =over 4
 494
 495 =item Arguments: $relname
 496
 497 =back
 498
 499 Returns a hash of relationship information for the specified relationship
 500 name.
 501
 502 =cut
 503
 504 sub relationship_info {
 505   my ($self, $rel) = @_;
 506   return $self->_relationships->{$rel};
 507 }
 508
 509 =head2 has_relationship
 510
 511 =over 4
 512
 513 =item Arguments: $rel
 514
 515 =back
 516
 517 Returns true if the source has a relationship of this name, false otherwise.
 518
 519 =cut
 520
 521 sub has_relationship {
 522   my ($self, $rel) = @_;
 523   return exists $self->_relationships->{$rel};
 524 }
 525
 526 =head2 reverse_relationship_info
 527
 528 =over 4
 529
 530 =item Arguments: $relname
 531
 532 =back
 533
 534 Returns an array of hash references of relationship information for
 535 the other side of the specified relationship name.
 536
 537 =cut
 538
 539 sub reverse_relationship_info {
 540   my ($self, $rel) = @_;
 541   my $rel_info = $self->relationship_info($rel);
 542   my $ret = {};
 543
 544   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 545
 546   my @cond = keys(%{$rel_info->{cond}});
 547   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
 548   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
 549
 550   # Get the related result source for this relationship
 551   my $othertable = $self->related_source($rel);
 552
 553   # Get all the relationships for that source that related to this source
 554   # whose foreign column set are our self columns on $rel and whose self
 555   # columns are our foreign columns on $rel.
 556   my @otherrels = $othertable->relationships();
 557   my $otherrelationship;
 558   foreach my $otherrel (@otherrels) {
 559     my $otherrel_info = $othertable->relationship_info($otherrel);
 560
 561     my $back = $othertable->related_source($otherrel);
 562     next unless $back->name eq $self->name;
 563
 564     my @othertestconds;
 565
 566     if (ref $otherrel_info->{cond} eq 'HASH') {
 567       @othertestconds = ($otherrel_info->{cond});
 568     }
 569     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
 570       @othertestconds = @{$otherrel_info->{cond}};
 571     }
 572     else {
 573       next;
 574     }
 575
 576     foreach my $othercond (@othertestconds) {
 577       my @other_cond = keys(%$othercond);
 578       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
 579       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
 580       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
 581                !$self->compare_relationship_keys(\@other_refkeys, \@keys));
 582       $ret->{$otherrel} =  $otherrel_info;
 583     }
 584   }
 585   return $ret;
 586 }
 587
 588 =head2 compare_relationship_keys
 589
 590 =over 4
 591
 592 =item Arguments: $keys1, $keys2
 593
 594 =back
 595
 596 Returns true if both sets of keynames are the same, false otherwise.
 597
 598 =cut
 599
 600 sub compare_relationship_keys {
 601   my ($self, $keys1, $keys2) = @_;
 602
 603   # Make sure every keys1 is in keys2
 604   my $found;
 605   foreach my $key (@$keys1) {
 606     $found = 0;
 607     foreach my $prim (@$keys2) {
 608       if ($prim eq $key) {
 609         $found = 1;
 610         last;
 611       }
 612     }
 613     last unless $found;
 614   }
 615
 616   # Make sure every key2 is in key1
 617   if ($found) {
 618     foreach my $prim (@$keys2) {
 619       $found = 0;
 620       foreach my $key (@$keys1) {
 621         if ($prim eq $key) {
 622           $found = 1;
 623           last;
 624         }
 625       }
 626       last unless $found;
 627     }
 628   }
 629
 630   return $found;
 631 }
 632
 633 =head2 resolve_join
 634
 635 =over 4
 636
 637 =item Arguments: $relation
 638
 639 =back
 640
 641 Returns the join structure required for the related result source.
 642
 643 =cut
 644
 645 sub resolve_join {
 646   my ($self, $join, $alias, $seen) = @_;
 647   $seen ||= {};
 648   if (ref $join eq 'ARRAY') {
 649     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 650   } elsif (ref $join eq 'HASH') {
 651     return
 652       map {
 653         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 654         ($self->resolve_join($_, $alias, $seen),
 655           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 656       } keys %$join;
 657   } elsif (ref $join) {
 658     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 659   } else {
 660     my $count = ++$seen->{$join};
 661     #use Data::Dumper; warn Dumper($seen);
 662     my $as = ($count > 1 ? "${join}_${count}" : $join);
 663     my $rel_info = $self->relationship_info($join);
 664     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 665     my $type = $rel_info->{attrs}{join_type} || '';
 666     return [ { $as => $self->related_source($join)->from,
 667                -join_type => $type },
 668              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 669   }
 670 }
 671
 672 =head2 resolve_condition
 673
 674 =over 4
 675
 676 =item Arguments: $cond, $as, $alias|$object
 677
 678 =back
 679
 680 Resolves the passed condition to a concrete query fragment. If given an alias,
 681 returns a join condition; if given an object, inverts that object to produce
 682 a related conditional from that object.
 683
 684 =cut
 685
 686 sub resolve_condition {
 687   my ($self, $cond, $as, $for) = @_;
 688   #warn %$cond;
 689   if (ref $cond eq 'HASH') {
 690     my %ret;
 691     foreach my $k (keys %{$cond}) {
 692       my $v = $cond->{$k};
 693       # XXX should probably check these are valid columns
 694       $k =~ s/^foreign\.// ||
 695         $self->throw_exception("Invalid rel cond key ${k}");
 696       $v =~ s/^self\.// ||
 697         $self->throw_exception("Invalid rel cond val ${v}");
 698       if (ref $for) { # Object
 699         #warn "$self $k $for $v";
 700         $ret{$k} = $for->get_column($v);
 701         #warn %ret;
 702       } elsif (!defined $for) { # undef, i.e. "no object"
 703         $ret{$k} = undef;
 704       } elsif (ref $as) { # reverse object
 705         $ret{$v} = $as->get_column($k);
 706       } elsif (!defined $as) { # undef, i.e. "no reverse object"
 707         $ret{$v} = undef;
 708       } else {
 709         $ret{"${as}.${k}"} = "${for}.${v}";
 710       }
 711     }
 712     return \%ret;
 713   } elsif (ref $cond eq 'ARRAY') {
 714     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 715   } else {
 716    die("Can't handle this yet :(");
 717   }
 718 }
 719
 720 =head2 resolve_prefetch
 721
 722 =over 4
 723
 724 =item Arguments: hashref/arrayref/scalar
 725
 726 =back
 727
 728 Accepts one or more relationships for the current source and returns an
 729 array of column names for each of those relationships. Column names are
 730 prefixed relative to the current source, in accordance with where they appear
 731 in the supplied relationships. Examples:
 732
 733   my $source = $schema->resultset('Tag')->source;
 734   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 735
 736   # @columns =
 737   #(
 738   #  'cd.cdid',
 739   #  'cd.artist',
 740   #  'cd.title',
 741   #  'cd.year',
 742   #  'cd.artist.artistid',
 743   #  'cd.artist.name'
 744   #)
 745
 746   @columns = $source->resolve_prefetch( qw[/ cd /] );
 747
 748   # @columns =
 749   #(
 750   #   'cd.cdid',
 751   #   'cd.artist',
 752   #   'cd.title',
 753   #   'cd.year'
 754   #)
 755
 756   $source = $schema->resultset('CD')->source;
 757   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 758
 759   # @columns =
 760   #(
 761   #  'artist.artistid',
 762   #  'artist.name',
 763   #  'producer.producerid',
 764   #  'producer.name'
 765   #)
 766
 767 =cut
 768
 769 sub resolve_prefetch {
 770   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 771   $seen ||= {};
 772   #$alias ||= $self->name;
 773   #warn $alias, Dumper $pre;
 774   if( ref $pre eq 'ARRAY' ) {
 775     return
 776       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 777         @$pre;
 778   }
 779   elsif( ref $pre eq 'HASH' ) {
 780     my @ret =
 781     map {
 782       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 783       $self->related_source($_)->resolve_prefetch(
 784                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 785     } keys %$pre;
 786     #die Dumper \@ret;
 787     return @ret;
 788   }
 789   elsif( ref $pre ) {
 790     $self->throw_exception(
 791       "don't know how to resolve prefetch reftype ".ref($pre));
 792   }
 793   else {
 794     my $count = ++$seen->{$pre};
 795     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 796     my $rel_info = $self->relationship_info( $pre );
 797     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 798       unless $rel_info;
 799     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 800     my $rel_source = $self->related_source($pre);
 801
 802     if (exists $rel_info->{attrs}{accessor}
 803          && $rel_info->{attrs}{accessor} eq 'multi') {
 804       $self->throw_exception(
 805         "Can't prefetch has_many ${pre} (join cond too complex)")
 806         unless ref($rel_info->{cond}) eq 'HASH';
 807       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 808                     keys %{$rel_info->{cond}};
 809       $collapse->{"${as_prefix}${pre}"} = \@key;
 810       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 811                    ? @{$rel_info->{attrs}{order_by}}
 812                    : (defined $rel_info->{attrs}{order_by}
 813                        ? ($rel_info->{attrs}{order_by})
 814                        : ()));
 815       push(@$order, map { "${as}.$_" } (@key, @ord));
 816     }
 817
 818     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 819       $rel_source->columns;
 820     #warn $alias, Dumper (\@ret);
 821     #return @ret;
 822   }
 823 }
 824
 825 =head2 related_source
 826
 827 =over 4
 828
 829 =item Arguments: $relname
 830
 831 =back
 832
 833 Returns the result source object for the given relationship.
 834
 835 =cut
 836
 837 sub related_source {
 838   my ($self, $rel) = @_;
 839   if( !$self->has_relationship( $rel ) ) {
 840     $self->throw_exception("No such relationship '$rel'");
 841   }
 842   return $self->schema->source($self->relationship_info($rel)->{source});
 843 }
 844
 845 =head2 related_class
 846
 847 =over 4
 848
 849 =item Arguments: $relname
 850
 851 =back
 852
 853 Returns the class name for objects in the given relationship.
 854
 855 =cut
 856
 857 sub related_class {
 858   my ($self, $rel) = @_;
 859   if( !$self->has_relationship( $rel ) ) {
 860     $self->throw_exception("No such relationship '$rel'");
 861   }
 862   return $self->schema->class($self->relationship_info($rel)->{source});
 863 }
 864
 865 =head2 resultset
 866
 867 Returns a resultset for the given source. This will initially be created
 868 on demand by calling
 869
 870   $self->resultset_class->new($self, $self->resultset_attributes)
 871
 872 but is cached from then on unless resultset_class changes.
 873
 874 =head2 resultset_class
 875
 876 Set the class of the resultset, this is useful if you want to create your
 877 own resultset methods. Create your own class derived from
 878 L<DBIx::Class::ResultSet>, and set it here.
 879
 880 =head2 resultset_attributes
 881
 882 Specify here any attributes you wish to pass to your specialised resultset.
 883
 884 =cut
 885
 886 sub resultset {
 887   my $self = shift;
 888   $self->throw_exception(
 889     'resultset does not take any arguments. If you want another resultset, '.
 890     'call it on the schema instead.'
 891   ) if scalar @_;
 892
 893   # disabled until we can figure out a way to do it without consistency issues
 894   #
 895   #return $self->{_resultset}
 896   #  if ref $self->{_resultset} eq $self->resultset_class;
 897   #return $self->{_resultset} =
 898
 899   return $self->resultset_class->new(
 900     $self, $self->{resultset_attributes}
 901   );
 902 }
 903
 904 =head2 source_name
 905
 906 =over 4
 907
 908 =item Arguments: $source_name
 909
 910 =back
 911
 912 Set the name of the result source when it is loaded into a schema.
 913 This is usefull if you want to refer to a result source by a name other than
 914 its class name.
 915
 916   package ArchivedBooks;
 917   use base qw/DBIx::Class/;
 918   __PACKAGE__->table('books_archive');
 919   __PACKAGE__->source_name('Books');
 920
 921   # from your schema...
 922   $schema->resultset('Books')->find(1);
 923
 924 =head2 throw_exception
 925
 926 See L<DBIx::Class::Schema/"throw_exception">.
 927
 928 =cut
 929
 930 sub throw_exception {
 931   my $self = shift;
 932   if (defined $self->schema) {
 933     $self->schema->throw_exception(@_);
 934   } else {
 935     croak(@_);
 936   }
 937 }
 938
 939 =head1 AUTHORS
 940
 941 Matt S. Trout <mst@shadowcatsystems.co.uk>
 942
 943 =head1 LICENSE
 944
 945 You may distribute this code under the same terms as Perl itself.
 946
 947 =cut
 948