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