lib/DBIx/Class/ResultSource.pm

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