lib/DBIx/Class/ResultSource.pm

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