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