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