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