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