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