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