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