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