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 column_info_from_storage source_name
  16   source_info/);
  17
  18 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
  19   result_class/);
  20
  21 =head1 NAME
  22
  23 DBIx::Class::ResultSource - Result source object
  24
  25 =head1 SYNOPSIS
  26
  27 =head1 DESCRIPTION
  28
  29 A ResultSource is a component of a schema from which results can be directly
  30 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
  31
  32 =head1 METHODS
  33
  34 =pod
  35
  36 =head2 new
  37
  38   $class->new();
  39
  40   $class->new({attribute_name => value});
  41
  42 Creates a new ResultSource object.  Not normally called directly by end users.
  43
  44 =cut
  45
  46 sub new {
  47   my ($class, $attrs) = @_;
  48   $class = ref $class if ref $class;
  49
  50   my $new = { %{$attrs || {}}, _resultset => undef };
  51   bless $new, $class;
  52
  53   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  54   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  55   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  56   $new->{_columns} = { %{$new->{_columns}||{}} };
  57   $new->{_relationships} = { %{$new->{_relationships}||{}} };
  58   $new->{name} ||= "!!NAME NOT SET!!";
  59   $new->{_columns_info_loaded} ||= 0;
  60   return $new;
  61 }
  62
  63 =pod
  64
  65 =head2 source_info
  66
  67 Stores a hashref of per-source metadata.  No specific key names
  68 have yet been standardized, the examples below are purely hypothetical
  69 and don't actually accomplish anything on their own:
  70
  71   __PACKAGE__->source_info({
  72     "_tablespace" => 'fast_disk_array_3',
  73     "_engine" => 'InnoDB',
  74   });
  75
  76 =head2 add_columns
  77
  78   $table->add_columns(qw/col1 col2 col3/);
  79
  80   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  81
  82 Adds columns to the result source. If supplied key => hashref pairs, uses
  83 the hashref as the column_info for that column. Repeated calls of this
  84 method will add more columns, not replace them.
  85
  86 The contents of the column_info are not set in stone. The following
  87 keys are currently recognised/used by DBIx::Class:
  88
  89 =over 4
  90
  91 =item accessor
  92
  93 Use this to set the name of the accessor for this column. If unset,
  94 the name of the column will be used.
  95
  96 =item data_type
  97
  98 This contains the column type. It is automatically filled by the
  99 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
 100 L<DBIx::Class::Schema::Loader> module. If you do not enter a
 101 data_type, DBIx::Class will attempt to retrieve it from the
 102 database for you, using L<DBI>'s column_info method. The values of this
 103 key are typically upper-cased.
 104
 105 Currently there is no standard set of values for the data_type. Use
 106 whatever your database supports.
 107
 108 =item size
 109
 110 The length of your column, if it is a column type that can have a size
 111 restriction. This is currently not used by DBIx::Class.
 112
 113 =item is_nullable
 114
 115 Set this to a true value for a columns that is allowed to contain
 116 NULL values. This is currently not used by DBIx::Class.
 117
 118 =item is_auto_increment
 119
 120 Set this to a true value for a column whose value is somehow
 121 automatically set. This is used to determine which columns to empty
 122 when cloning objects using C<copy>.
 123
 124 =item is_foreign_key
 125
 126 Set this to a true value for a column that contains a key from a
 127 foreign table. This is currently not used by DBIx::Class.
 128
 129 =item default_value
 130
 131 Set this to the default value which will be inserted into a column
 132 by the database. Can contain either a value or a function. This is
 133 currently not used by DBIx::Class.
 134
 135 =item sequence
 136
 137 Set this on a primary key column to the name of the sequence used to
 138 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
 139 will attempt to retrieve the name of the sequence from the database
 140 automatically.
 141
 142 =back
 143
 144 =head2 add_column
 145
 146   $table->add_column('col' => \%info?);
 147
 148 Convenience alias to add_columns.
 149
 150 =cut
 151
 152 sub add_columns {
 153   my ($self, @cols) = @_;
 154   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
 155
 156   my @added;
 157   my $columns = $self->_columns;
 158   while (my $col = shift @cols) {
 159     # If next entry is { ... } use that for the column info, if not
 160     # use an empty hashref
 161     my $column_info = ref $cols[0] ? shift(@cols) : {};
 162     push(@added, $col) unless exists $columns->{$col};
 163     $columns->{$col} = $column_info;
 164   }
 165   push @{ $self->_ordered_columns }, @added;
 166   return $self;
 167 }
 168
 169 *add_column = \&add_columns;
 170
 171 =head2 has_column
 172
 173   if ($obj->has_column($col)) { ... }
 174
 175 Returns true if the source has a column of this name, false otherwise.
 176
 177 =cut
 178
 179 sub has_column {
 180   my ($self, $column) = @_;
 181   return exists $self->_columns->{$column};
 182 }
 183
 184 =head2 column_info
 185
 186   my $info = $obj->column_info($col);
 187
 188 Returns the column metadata hashref for a column. See the description
 189 of add_column for information on the contents of the hashref.
 190
 191 =cut
 192
 193 sub column_info {
 194   my ($self, $column) = @_;
 195   $self->throw_exception("No such column $column")
 196     unless exists $self->_columns->{$column};
 197   #warn $self->{_columns_info_loaded}, "\n";
 198   if ( ! $self->_columns->{$column}{data_type}
 199        and $self->column_info_from_storage
 200        and ! $self->{_columns_info_loaded}
 201        and $self->schema and $self->storage )
 202   {
 203     $self->{_columns_info_loaded}++;
 204     my $info;
 205     my $lc_info;
 206     # eval for the case of storage without table
 207     eval { $info = $self->storage->columns_info_for( $self->from ) };
 208     unless ($@) {
 209       for my $realcol ( keys %{$info} ) {
 210         $lc_info->{lc $realcol} = $info->{$realcol};
 211       }
 212       foreach my $col ( keys %{$self->_columns} ) {
 213         $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
 214       }
 215     }
 216   }
 217   return $self->_columns->{$column};
 218 }
 219
 220 =head2 load_column_info_from_storage
 221
 222 Enables the on-demand automatic loading of the above column
 223 metadata from storage as neccesary.
 224
 225 =cut
 226
 227 sub load_column_info_from_storage { shift->column_info_from_storage(1) }
 228
 229 =head2 columns
 230
 231   my @column_names = $obj->columns;
 232
 233 Returns all column names in the order they were declared to add_columns.
 234
 235 =cut
 236
 237 sub columns {
 238   my $self = shift;
 239   $self->throw_exception(
 240     "columns() is a read-only accessor, did you mean add_columns()?"
 241   ) if (@_ > 1);
 242   return @{$self->{_ordered_columns}||[]};
 243 }
 244
 245 =head2 remove_columns
 246
 247   $table->remove_columns(qw/col1 col2 col3/);
 248
 249 Removes columns from the result source.
 250
 251 =head2 remove_column
 252
 253   $table->remove_column('col');
 254
 255 Convenience alias to remove_columns.
 256
 257 =cut
 258
 259 sub remove_columns {
 260   my ($self, @cols) = @_;
 261
 262   return unless $self->_ordered_columns;
 263
 264   my $columns = $self->_columns;
 265   my @remaining;
 266
 267   foreach my $col (@{$self->_ordered_columns}) {
 268     push @remaining, $col unless grep(/$col/, @cols);
 269   }
 270
 271   foreach (@cols) {
 272     delete $columns->{$_};
 273   };
 274
 275   $self->_ordered_columns(\@remaining);
 276 }
 277
 278 *remove_column = \&remove_columns;
 279
 280 =head2 set_primary_key
 281
 282 =over 4
 283
 284 =item Arguments: @cols
 285
 286 =back
 287
 288 Defines one or more columns as primary key for this source. Should be
 289 called after C<add_columns>.
 290
 291 Additionally, defines a unique constraint named C<primary>.
 292
 293 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 294 retrieve automatically created values from the database.
 295
 296 =cut
 297
 298 sub set_primary_key {
 299   my ($self, @cols) = @_;
 300   # check if primary key columns are valid columns
 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   $self->_primaries(\@cols);
 306
 307   $self->add_unique_constraint(primary => \@cols);
 308 }
 309
 310 =head2 primary_columns
 311
 312 Read-only accessor which returns the list of primary keys.
 313
 314 =cut
 315
 316 sub primary_columns {
 317   return @{shift->_primaries||[]};
 318 }
 319
 320 =head2 add_unique_constraint
 321
 322 Declare a unique constraint on this source. Call once for each unique
 323 constraint.
 324
 325   # For UNIQUE (column1, column2)
 326   __PACKAGE__->add_unique_constraint(
 327     constraint_name => [ qw/column1 column2/ ],
 328   );
 329
 330 Alternatively, you can specify only the columns:
 331
 332   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
 333
 334 This will result in a unique constraint named C<table_column1_column2>, where
 335 C<table> is replaced with the table name.
 336
 337 Unique constraints are used, for example, when you call
 338 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
 339
 340 =cut
 341
 342 sub add_unique_constraint {
 343   my $self = shift;
 344   my $cols = pop @_;
 345   my $name = shift;
 346
 347   $name ||= $self->name_unique_constraint($cols);
 348
 349   foreach my $col (@$cols) {
 350     $self->throw_exception("No such column $col on table " . $self->name)
 351       unless $self->has_column($col);
 352   }
 353
 354   my %unique_constraints = $self->unique_constraints;
 355   $unique_constraints{$name} = $cols;
 356   $self->_unique_constraints(\%unique_constraints);
 357 }
 358
 359 =head2 name_unique_constraint
 360
 361 Return a name for a unique constraint containing the specified columns. These
 362 names consist of the table name and each column name, separated by underscores.
 363
 364 For example, a constraint on a table named C<cd> containing the columns
 365 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 366
 367 =cut
 368
 369 sub name_unique_constraint {
 370   my ($self, $cols) = @_;
 371
 372   return join '_', $self->name, @$cols;
 373 }
 374
 375 =head2 unique_constraints
 376
 377 Read-only accessor which returns the list of unique constraints on this source.
 378
 379 =cut
 380
 381 sub unique_constraints {
 382   return %{shift->_unique_constraints||{}};
 383 }
 384
 385 =head2 unique_constraint_names
 386
 387 Returns the list of unique constraint names defined on this source.
 388
 389 =cut
 390
 391 sub unique_constraint_names {
 392   my ($self) = @_;
 393
 394   my %unique_constraints = $self->unique_constraints;
 395
 396   return keys %unique_constraints;
 397 }
 398
 399 =head2 unique_constraint_columns
 400
 401 Returns the list of columns that make up the specified unique constraint.
 402
 403 =cut
 404
 405 sub unique_constraint_columns {
 406   my ($self, $constraint_name) = @_;
 407
 408   my %unique_constraints = $self->unique_constraints;
 409
 410   $self->throw_exception(
 411     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 412   ) unless exists $unique_constraints{$constraint_name};
 413
 414   return @{ $unique_constraints{$constraint_name} };
 415 }
 416
 417 =head2 from
 418
 419 Returns an expression of the source to be supplied to storage to specify
 420 retrieval from this source. In the case of a database, the required FROM
 421 clause contents.
 422
 423 =head2 schema
 424
 425 Returns the L<DBIx::Class::Schema> object that this result source
 426 belongs too.
 427
 428 =head2 storage
 429
 430 Returns the storage handle for the current schema.
 431
 432 See also: L<DBIx::Class::Storage>
 433
 434 =cut
 435
 436 sub storage { shift->schema->storage; }
 437
 438 =head2 add_relationship
 439
 440   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 441
 442 The relationship name can be arbitrary, but must be unique for each
 443 relationship attached to this result source. 'related_source' should
 444 be the name with which the related result source was registered with
 445 the current schema. For example:
 446
 447   $schema->source('Book')->add_relationship('reviews', 'Review', {
 448     'foreign.book_id' => 'self.id',
 449   });
 450
 451 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 452 representation of the join between the tables. For example, if you're
 453 creating a rel from Author to Book,
 454
 455   { 'foreign.author_id' => 'self.id' }
 456
 457 will result in the JOIN clause
 458
 459   author me JOIN book foreign ON foreign.author_id = me.id
 460
 461 You can specify as many foreign => self mappings as necessary.
 462
 463 Valid attributes are as follows:
 464
 465 =over 4
 466
 467 =item join_type
 468
 469 Explicitly specifies the type of join to use in the relationship. Any
 470 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 471 the SQL command immediately before C<JOIN>.
 472
 473 =item proxy
 474
 475 An arrayref containing a list of accessors in the foreign class to proxy in
 476 the main class. If, for example, you do the following:
 477
 478   CD->might_have(liner_notes => 'LinerNotes', undef, {
 479     proxy => [ qw/notes/ ],
 480   });
 481
 482 Then, assuming LinerNotes has an accessor named notes, you can do:
 483
 484   my $cd = CD->find(1);
 485   # set notes -- LinerNotes object is created if it doesn't exist
 486   $cd->notes('Notes go here');
 487
 488 =item accessor
 489
 490 Specifies the type of accessor that should be created for the
 491 relationship. Valid values are C<single> (for when there is only a single
 492 related object), C<multi> (when there can be many), and C<filter> (for
 493 when there is a single related object, but you also want the relationship
 494 accessor to double as a column accessor). For C<multi> accessors, an
 495 add_to_* method is also created, which calls C<create_related> for the
 496 relationship.
 497
 498 =back
 499
 500 =cut
 501
 502 sub add_relationship {
 503   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 504   $self->throw_exception("Can't create relationship without join condition")
 505     unless $cond;
 506   $attrs ||= {};
 507
 508   my %rels = %{ $self->_relationships };
 509   $rels{$rel} = { class => $f_source_name,
 510                   source => $f_source_name,
 511                   cond  => $cond,
 512                   attrs => $attrs };
 513   $self->_relationships(\%rels);
 514
 515   return $self;
 516
 517   # XXX disabled. doesn't work properly currently. skip in tests.
 518
 519   my $f_source = $self->schema->source($f_source_name);
 520   unless ($f_source) {
 521     $self->ensure_class_loaded($f_source_name);
 522     $f_source = $f_source_name->result_source;
 523     #my $s_class = ref($self->schema);
 524     #$f_source_name =~ m/^${s_class}::(.*)$/;
 525     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 526     #$f_source = $self->schema->source($f_source_name);
 527   }
 528   return unless $f_source; # Can't test rel without f_source
 529
 530   eval { $self->resolve_join($rel, 'me') };
 531
 532   if ($@) { # If the resolve failed, back out and re-throw the error
 533     delete $rels{$rel}; #
 534     $self->_relationships(\%rels);
 535     $self->throw_exception("Error creating relationship $rel: $@");
 536   }
 537   1;
 538 }
 539
 540 =head2 relationships
 541
 542 Returns all relationship names for this source.
 543
 544 =cut
 545
 546 sub relationships {
 547   return keys %{shift->_relationships};
 548 }
 549
 550 =head2 relationship_info
 551
 552 =over 4
 553
 554 =item Arguments: $relname
 555
 556 =back
 557
 558 Returns a hash of relationship information for the specified relationship
 559 name.
 560
 561 =cut
 562
 563 sub relationship_info {
 564   my ($self, $rel) = @_;
 565   return $self->_relationships->{$rel};
 566 }
 567
 568 =head2 has_relationship
 569
 570 =over 4
 571
 572 =item Arguments: $rel
 573
 574 =back
 575
 576 Returns true if the source has a relationship of this name, false otherwise.
 577
 578 =cut
 579
 580 sub has_relationship {
 581   my ($self, $rel) = @_;
 582   return exists $self->_relationships->{$rel};
 583 }
 584
 585 =head2 reverse_relationship_info
 586
 587 =over 4
 588
 589 =item Arguments: $relname
 590
 591 =back
 592
 593 Returns an array of hash references of relationship information for
 594 the other side of the specified relationship name.
 595
 596 =cut
 597
 598 sub reverse_relationship_info {
 599   my ($self, $rel) = @_;
 600   my $rel_info = $self->relationship_info($rel);
 601   my $ret = {};
 602
 603   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 604
 605   my @cond = keys(%{$rel_info->{cond}});
 606   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
 607   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
 608
 609   # Get the related result source for this relationship
 610   my $othertable = $self->related_source($rel);
 611
 612   # Get all the relationships for that source that related to this source
 613   # whose foreign column set are our self columns on $rel and whose self
 614   # columns are our foreign columns on $rel.
 615   my @otherrels = $othertable->relationships();
 616   my $otherrelationship;
 617   foreach my $otherrel (@otherrels) {
 618     my $otherrel_info = $othertable->relationship_info($otherrel);
 619
 620     my $back = $othertable->related_source($otherrel);
 621     next unless $back->name eq $self->name;
 622
 623     my @othertestconds;
 624
 625     if (ref $otherrel_info->{cond} eq 'HASH') {
 626       @othertestconds = ($otherrel_info->{cond});
 627     }
 628     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
 629       @othertestconds = @{$otherrel_info->{cond}};
 630     }
 631     else {
 632       next;
 633     }
 634
 635     foreach my $othercond (@othertestconds) {
 636       my @other_cond = keys(%$othercond);
 637       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
 638       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
 639       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
 640                !$self->compare_relationship_keys(\@other_refkeys, \@keys));
 641       $ret->{$otherrel} =  $otherrel_info;
 642     }
 643   }
 644   return $ret;
 645 }
 646
 647 =head2 compare_relationship_keys
 648
 649 =over 4
 650
 651 =item Arguments: $keys1, $keys2
 652
 653 =back
 654
 655 Returns true if both sets of keynames are the same, false otherwise.
 656
 657 =cut
 658
 659 sub compare_relationship_keys {
 660   my ($self, $keys1, $keys2) = @_;
 661
 662   # Make sure every keys1 is in keys2
 663   my $found;
 664   foreach my $key (@$keys1) {
 665     $found = 0;
 666     foreach my $prim (@$keys2) {
 667       if ($prim eq $key) {
 668         $found = 1;
 669         last;
 670       }
 671     }
 672     last unless $found;
 673   }
 674
 675   # Make sure every key2 is in key1
 676   if ($found) {
 677     foreach my $prim (@$keys2) {
 678       $found = 0;
 679       foreach my $key (@$keys1) {
 680         if ($prim eq $key) {
 681           $found = 1;
 682           last;
 683         }
 684       }
 685       last unless $found;
 686     }
 687   }
 688
 689   return $found;
 690 }
 691
 692 =head2 resolve_join
 693
 694 =over 4
 695
 696 =item Arguments: $relation
 697
 698 =back
 699
 700 Returns the join structure required for the related result source.
 701
 702 =cut
 703
 704 sub resolve_join {
 705   my ($self, $join, $alias, $seen) = @_;
 706   $seen ||= {};
 707   if (ref $join eq 'ARRAY') {
 708     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 709   } elsif (ref $join eq 'HASH') {
 710     return
 711       map {
 712         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 713         ($self->resolve_join($_, $alias, $seen),
 714           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 715       } keys %$join;
 716   } elsif (ref $join) {
 717     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 718   } else {
 719     my $count = ++$seen->{$join};
 720     #use Data::Dumper; warn Dumper($seen);
 721     my $as = ($count > 1 ? "${join}_${count}" : $join);
 722     my $rel_info = $self->relationship_info($join);
 723     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 724     my $type = $rel_info->{attrs}{join_type} || '';
 725     return [ { $as => $self->related_source($join)->from,
 726                -join_type => $type },
 727              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 728   }
 729 }
 730
 731 =head2 resolve_condition
 732
 733 =over 4
 734
 735 =item Arguments: $cond, $as, $alias|$object
 736
 737 =back
 738
 739 Resolves the passed condition to a concrete query fragment. If given an alias,
 740 returns a join condition; if given an object, inverts that object to produce
 741 a related conditional from that object.
 742
 743 =cut
 744
 745 sub resolve_condition {
 746   my ($self, $cond, $as, $for) = @_;
 747   #warn %$cond;
 748   if (ref $cond eq 'HASH') {
 749     my %ret;
 750     foreach my $k (keys %{$cond}) {
 751       my $v = $cond->{$k};
 752       # XXX should probably check these are valid columns
 753       $k =~ s/^foreign\.// ||
 754         $self->throw_exception("Invalid rel cond key ${k}");
 755       $v =~ s/^self\.// ||
 756         $self->throw_exception("Invalid rel cond val ${v}");
 757       if (ref $for) { # Object
 758         #warn "$self $k $for $v";
 759         $ret{$k} = $for->get_column($v);
 760         #warn %ret;
 761       } elsif (!defined $for) { # undef, i.e. "no object"
 762         $ret{$k} = undef;
 763       } elsif (ref $as) { # reverse object
 764         $ret{$v} = $as->get_column($k);
 765       } elsif (!defined $as) { # undef, i.e. "no reverse object"
 766         $ret{$v} = undef;
 767       } else {
 768         $ret{"${as}.${k}"} = "${for}.${v}";
 769       }
 770     }
 771     return \%ret;
 772   } elsif (ref $cond eq 'ARRAY') {
 773     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 774   } else {
 775    die("Can't handle this yet :(");
 776   }
 777 }
 778
 779 =head2 resolve_prefetch
 780
 781 =over 4
 782
 783 =item Arguments: hashref/arrayref/scalar
 784
 785 =back
 786
 787 Accepts one or more relationships for the current source and returns an
 788 array of column names for each of those relationships. Column names are
 789 prefixed relative to the current source, in accordance with where they appear
 790 in the supplied relationships. Examples:
 791
 792   my $source = $schema->resultset('Tag')->source;
 793   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 794
 795   # @columns =
 796   #(
 797   #  'cd.cdid',
 798   #  'cd.artist',
 799   #  'cd.title',
 800   #  'cd.year',
 801   #  'cd.artist.artistid',
 802   #  'cd.artist.name'
 803   #)
 804
 805   @columns = $source->resolve_prefetch( qw[/ cd /] );
 806
 807   # @columns =
 808   #(
 809   #   'cd.cdid',
 810   #   'cd.artist',
 811   #   'cd.title',
 812   #   'cd.year'
 813   #)
 814
 815   $source = $schema->resultset('CD')->source;
 816   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 817
 818   # @columns =
 819   #(
 820   #  'artist.artistid',
 821   #  'artist.name',
 822   #  'producer.producerid',
 823   #  'producer.name'
 824   #)
 825
 826 =cut
 827
 828 sub resolve_prefetch {
 829   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 830   $seen ||= {};
 831   #$alias ||= $self->name;
 832   #warn $alias, Dumper $pre;
 833   if( ref $pre eq 'ARRAY' ) {
 834     return
 835       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 836         @$pre;
 837   }
 838   elsif( ref $pre eq 'HASH' ) {
 839     my @ret =
 840     map {
 841       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 842       $self->related_source($_)->resolve_prefetch(
 843                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 844     } keys %$pre;
 845     #die Dumper \@ret;
 846     return @ret;
 847   }
 848   elsif( ref $pre ) {
 849     $self->throw_exception(
 850       "don't know how to resolve prefetch reftype ".ref($pre));
 851   }
 852   else {
 853     my $count = ++$seen->{$pre};
 854     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 855     my $rel_info = $self->relationship_info( $pre );
 856     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 857       unless $rel_info;
 858     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 859     my $rel_source = $self->related_source($pre);
 860
 861     if (exists $rel_info->{attrs}{accessor}
 862          && $rel_info->{attrs}{accessor} eq 'multi') {
 863       $self->throw_exception(
 864         "Can't prefetch has_many ${pre} (join cond too complex)")
 865         unless ref($rel_info->{cond}) eq 'HASH';
 866       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 867                     keys %{$rel_info->{cond}};
 868       $collapse->{"${as_prefix}${pre}"} = \@key;
 869       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 870                    ? @{$rel_info->{attrs}{order_by}}
 871                    : (defined $rel_info->{attrs}{order_by}
 872                        ? ($rel_info->{attrs}{order_by})
 873                        : ()));
 874       push(@$order, map { "${as}.$_" } (@key, @ord));
 875     }
 876
 877     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 878       $rel_source->columns;
 879     #warn $alias, Dumper (\@ret);
 880     #return @ret;
 881   }
 882 }
 883
 884 =head2 related_source
 885
 886 =over 4
 887
 888 =item Arguments: $relname
 889
 890 =back
 891
 892 Returns the result source object for the given relationship.
 893
 894 =cut
 895
 896 sub related_source {
 897   my ($self, $rel) = @_;
 898   if( !$self->has_relationship( $rel ) ) {
 899     $self->throw_exception("No such relationship '$rel'");
 900   }
 901   return $self->schema->source($self->relationship_info($rel)->{source});
 902 }
 903
 904 =head2 related_class
 905
 906 =over 4
 907
 908 =item Arguments: $relname
 909
 910 =back
 911
 912 Returns the class name for objects in the given relationship.
 913
 914 =cut
 915
 916 sub related_class {
 917   my ($self, $rel) = @_;
 918   if( !$self->has_relationship( $rel ) ) {
 919     $self->throw_exception("No such relationship '$rel'");
 920   }
 921   return $self->schema->class($self->relationship_info($rel)->{source});
 922 }
 923
 924 =head2 resultset
 925
 926 Returns a resultset for the given source. This will initially be created
 927 on demand by calling
 928
 929   $self->resultset_class->new($self, $self->resultset_attributes)
 930
 931 but is cached from then on unless resultset_class changes.
 932
 933 =head2 resultset_class
 934
 935 Set the class of the resultset, this is useful if you want to create your
 936 own resultset methods. Create your own class derived from
 937 L<DBIx::Class::ResultSet>, and set it here.
 938
 939 =head2 resultset_attributes
 940
 941 Specify here any attributes you wish to pass to your specialised resultset.
 942
 943 =cut
 944
 945 sub resultset {
 946   my $self = shift;
 947   $self->throw_exception(
 948     'resultset does not take any arguments. If you want another resultset, '.
 949     'call it on the schema instead.'
 950   ) if scalar @_;
 951
 952   # disabled until we can figure out a way to do it without consistency issues
 953   #
 954   #return $self->{_resultset}
 955   #  if ref $self->{_resultset} eq $self->resultset_class;
 956   #return $self->{_resultset} =
 957
 958   return $self->resultset_class->new(
 959     $self, $self->{resultset_attributes}
 960   );
 961 }
 962
 963 =head2 source_name
 964
 965 =over 4
 966
 967 =item Arguments: $source_name
 968
 969 =back
 970
 971 Set the name of the result source when it is loaded into a schema.
 972 This is usefull if you want to refer to a result source by a name other than
 973 its class name.
 974
 975   package ArchivedBooks;
 976   use base qw/DBIx::Class/;
 977   __PACKAGE__->table('books_archive');
 978   __PACKAGE__->source_name('Books');
 979
 980   # from your schema...
 981   $schema->resultset('Books')->find(1);
 982
 983 =head2 throw_exception
 984
 985 See L<DBIx::Class::Schema/"throw_exception">.
 986
 987 =cut
 988
 989 sub throw_exception {
 990   my $self = shift;
 991   if (defined $self->schema) {
 992     $self->schema->throw_exception(@_);
 993   } else {
 994     croak(@_);
 995   }
 996 }
 997
 998 =head1 AUTHORS
 999
1000 Matt S. Trout <mst@shadowcatsystems.co.uk>
1001
1002 =head1 LICENSE
1003
1004 You may distribute this code under the same terms as Perl itself.
1005
1006 =cut
1007