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