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