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