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