lib/DBIx/Class/ResultSource.pm

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