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