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