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