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