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 =head2 add_columns
  75
  76 =over
  77
  78 =item Arguments: @columns
  79
  80 =item Return value: The ResultSource object
  81
  82 =back
  83
  84   $table->add_columns(qw/col1 col2 col3/);
  85
  86   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  87
  88 Adds columns to the result source. If supplied key => hashref pairs, uses
  89 the hashref as the column_info for that column. Repeated calls of this
  90 method will add more columns, not replace them.
  91
  92 The column names given will be created as accessor methods on your
  93 L<DBIx::Class::Row> objects, you can change the name of the accessor
  94 by supplying an L</accessor> in the column_info hash.
  95
  96 The contents of the column_info are not set in stone. The following
  97 keys are currently recognised/used by DBIx::Class:
  98
  99 =over 4
 100
 101 =item accessor
 102
 103 Use this to set the name of the accessor method for this column. If unset,
 104 the name of the column will be used.
 105
 106 =item data_type
 107
 108 This contains the column type. It is automatically filled by the
 109 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
 110 L<DBIx::Class::Schema::Loader> module. If you do not enter a
 111 data_type, DBIx::Class will attempt to retrieve it from the
 112 database for you, using L<DBI>'s column_info method. The values of this
 113 key are typically upper-cased.
 114
 115 Currently there is no standard set of values for the data_type. Use
 116 whatever your database supports.
 117
 118 =item size
 119
 120 The length of your column, if it is a column type that can have a size
 121 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
 122
 123 =item is_nullable
 124
 125 Set this to a true value for a columns that is allowed to contain
 126 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
 127
 128 =item is_auto_increment
 129
 130 Set this to a true value for a column whose value is somehow
 131 automatically set. This is used to determine which columns to empty
 132 when cloning objects using C<copy>. It is also used by
 133 L<DBIx::Class::Schema/deploy>.
 134
 135 =item is_foreign_key
 136
 137 Set this to a true value for a column that contains a key from a
 138 foreign table. This is currently only used by
 139 L<DBIx::Class::Schema/deploy>.
 140
 141 =item default_value
 142
 143 Set this to the default value which will be inserted into a column
 144 by the database. Can contain either a value or a function. This is
 145 currently only used by L<DBIx::Class::Schema/deploy>.
 146
 147 =item sequence
 148
 149 Set this on a primary key column to the name of the sequence used to
 150 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
 151 will attempt to retrieve the name of the sequence from the database
 152 automatically.
 153
 154 =item auto_nextval
 155
 156 Set this to a true value for a column whose value is retrieved
 157 automatically from an oracle sequence. If you do not use an oracle
 158 trigger to get the nextval, you have to set sequence as well.
 159
 160 =item extra
 161
 162 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
 163 to add extra non-generic data to the column. For example: C<< extra
 164 => { unsigned => 1} >> is used by the MySQL producer to set an integer
 165 column to unsigned. For more details, see
 166 L<SQL::Translator::Producer::MySQL>.
 167
 168 =back
 169
 170 =head2 add_column
 171
 172 =over
 173
 174 =item Arguments: $colname, [ \%columninfo ]
 175
 176 =item Return value: 1/0 (true/false)
 177
 178 =back
 179
 180   $table->add_column('col' => \%info?);
 181
 182 Add a single column and optional column info. Uses the same column
 183 info keys as L</add_columns>.
 184
 185 =cut
 186
 187 sub add_columns {
 188   my ($self, @cols) = @_;
 189   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
 190
 191   my @added;
 192   my $columns = $self->_columns;
 193   while (my $col = shift @cols) {
 194     # If next entry is { ... } use that for the column info, if not
 195     # use an empty hashref
 196     my $column_info = ref $cols[0] ? shift(@cols) : {};
 197     push(@added, $col) unless exists $columns->{$col};
 198     $columns->{$col} = $column_info;
 199   }
 200   push @{ $self->_ordered_columns }, @added;
 201   return $self;
 202 }
 203
 204 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 205
 206 =head2 has_column
 207
 208 =over
 209
 210 =item Arguments: $colname
 211
 212 =item Return value: 1/0 (true/false)
 213
 214 =back
 215
 216   if ($obj->has_column($colname)) { ... }
 217
 218 Returns true if the source has a column of this name, false otherwise.
 219
 220 =cut
 221
 222 sub has_column {
 223   my ($self, $column) = @_;
 224   return exists $self->_columns->{$column};
 225 }
 226
 227 =head2 column_info
 228
 229 =over
 230
 231 =item Arguments: $colname
 232
 233 =item Return value: Hashref of info
 234
 235 =back
 236
 237   my $info = $obj->column_info($col);
 238
 239 Returns the column metadata hashref for a column, as originally passed
 240 to L</add_columns>. See the description of L</add_columns> for information
 241 on the contents of the hashref.
 242
 243 =cut
 244
 245 sub column_info {
 246   my ($self, $column) = @_;
 247   $self->throw_exception("No such column $column")
 248     unless exists $self->_columns->{$column};
 249   #warn $self->{_columns_info_loaded}, "\n";
 250   if ( ! $self->_columns->{$column}{data_type}
 251        and $self->column_info_from_storage
 252        and ! $self->{_columns_info_loaded}
 253        and $self->schema and $self->storage )
 254   {
 255     $self->{_columns_info_loaded}++;
 256     my $info = {};
 257     my $lc_info = {};
 258     # eval for the case of storage without table
 259     eval { $info = $self->storage->columns_info_for( $self->from ) };
 260     unless ($@) {
 261       for my $realcol ( keys %{$info} ) {
 262         $lc_info->{lc $realcol} = $info->{$realcol};
 263       }
 264       foreach my $col ( keys %{$self->_columns} ) {
 265         $self->_columns->{$col} = {
 266           %{ $self->_columns->{$col} },
 267           %{ $info->{$col} || $lc_info->{lc $col} || {} }
 268         };
 269       }
 270     }
 271   }
 272   return $self->_columns->{$column};
 273 }
 274
 275 =head2 column_info_from_storage
 276
 277 =over
 278
 279 =item Arguments: 1/0 (default: 0)
 280
 281 =item Return value: 1/0
 282
 283 =back
 284
 285 Enables the on-demand automatic loading of the above column
 286 metadata from storage as neccesary.  This is *deprecated*, and
 287 should not be used.  It will be removed before 1.0.
 288
 289   __PACKAGE__->column_info_from_storage(1);
 290
 291 =head2 columns
 292
 293 =over
 294
 295 =item Arguments: None
 296
 297 =item Return value: Ordered list of column names
 298
 299 =back
 300
 301   my @column_names = $source->columns;
 302
 303 Returns all column names in the order they were declared to L</add_columns>.
 304
 305 =cut
 306
 307 sub columns {
 308   my $self = shift;
 309   $self->throw_exception(
 310     "columns() is a read-only accessor, did you mean add_columns()?"
 311   ) if (@_ > 1);
 312   return @{$self->{_ordered_columns}||[]};
 313 }
 314
 315 =head2 remove_columns
 316
 317 =over
 318
 319 =item Arguments: @colnames
 320
 321 =item Return value: undefined
 322
 323 =back
 324
 325   $source->remove_columns(qw/col1 col2 col3/);
 326
 327 Removes the given list of columns by name, from the result source.
 328
 329 B<Warning>: Removing a column that is also used in the sources primary
 330 key, or in one of the sources unique constraints, B<will> result in a
 331 broken result source.
 332
 333 =head2 remove_column
 334
 335 =over
 336
 337 =item Arguments: $colname
 338
 339 =item Return value: undefined
 340
 341 =back
 342
 343   $source->remove_column('col');
 344
 345 Remove a single column by name from the result source, similar to
 346 L</remove_columns>.
 347
 348 B<Warning>: Removing a column that is also used in the sources primary
 349 key, or in one of the sources unique constraints, B<will> result in a
 350 broken result source.
 351
 352 =cut
 353
 354 sub remove_columns {
 355   my ($self, @cols) = @_;
 356
 357   return unless $self->_ordered_columns;
 358
 359   my $columns = $self->_columns;
 360   my @remaining;
 361
 362   foreach my $col (@{$self->_ordered_columns}) {
 363     push @remaining, $col unless grep(/$col/, @cols);
 364   }
 365
 366   foreach (@cols) {
 367     delete $columns->{$_};
 368   };
 369
 370   $self->_ordered_columns(\@remaining);
 371 }
 372
 373 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 374
 375 =head2 set_primary_key
 376
 377 =over 4
 378
 379 =item Arguments: @cols
 380
 381 =item Return value: undefined
 382
 383 =back
 384
 385 Defines one or more columns as primary key for this source. Should be
 386 called after L</add_columns>.
 387
 388 Additionally, defines a L<unique constraint|add_unique_constraint>
 389 named C<primary>.
 390
 391 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 392 retrieve automatically created values from the database.
 393
 394 =cut
 395
 396 sub set_primary_key {
 397   my ($self, @cols) = @_;
 398   # check if primary key columns are valid columns
 399   foreach my $col (@cols) {
 400     $self->throw_exception("No such column $col on table " . $self->name)
 401       unless $self->has_column($col);
 402   }
 403   $self->_primaries(\@cols);
 404
 405   $self->add_unique_constraint(primary => \@cols);
 406 }
 407
 408 =head2 primary_columns
 409
 410 =over 4
 411
 412 =item Arguments: None
 413
 414 =item Return value: Ordered list of primary column names
 415
 416 =back
 417
 418 Read-only accessor which returns the list of primary keys, supplied by
 419 L</set_primary_key>.
 420
 421 =cut
 422
 423 sub primary_columns {
 424   return @{shift->_primaries||[]};
 425 }
 426
 427 =head2 add_unique_constraint
 428
 429 =over 4
 430
 431 =item Arguments: [ $name ], \@colnames
 432
 433 =item Return value: undefined
 434
 435 =back
 436
 437 Declare a unique constraint on this source. Call once for each unique
 438 constraint.
 439
 440   # For UNIQUE (column1, column2)
 441   __PACKAGE__->add_unique_constraint(
 442     constraint_name => [ qw/column1 column2/ ],
 443   );
 444
 445 Alternatively, you can specify only the columns:
 446
 447   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
 448
 449 This will result in a unique constraint named C<table_column1_column2>, where
 450 C<table> is replaced with the table name.
 451
 452 Unique constraints are used, for example, when you call
 453 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
 454
 455 Throws an error if any of the given column names do not yet exist on
 456 the result source.
 457
 458 =cut
 459
 460 sub add_unique_constraint {
 461   my $self = shift;
 462   my $cols = pop @_;
 463   my $name = shift;
 464
 465   $name ||= $self->name_unique_constraint($cols);
 466
 467   foreach my $col (@$cols) {
 468     $self->throw_exception("No such column $col on table " . $self->name)
 469       unless $self->has_column($col);
 470   }
 471
 472   my %unique_constraints = $self->unique_constraints;
 473   $unique_constraints{$name} = $cols;
 474   $self->_unique_constraints(\%unique_constraints);
 475 }
 476
 477 =head2 name_unique_constraint
 478
 479 =over 4
 480
 481 =item Arguments: @colnames
 482
 483 =item Return value: Constraint name
 484
 485 =back
 486
 487   $source->table('mytable');
 488   $source->name_unique_constraint('col1', 'col2');
 489   # returns
 490   'mytable_col1_col2'
 491
 492 Return a name for a unique constraint containing the specified
 493 columns. The name is created by joining the table name and each column
 494 name, using an underscore character.
 495
 496 For example, a constraint on a table named C<cd> containing the columns
 497 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 498
 499 This is used by L</add_unique_constraint> if you do not specify the
 500 optional constraint name.
 501
 502 =cut
 503
 504 sub name_unique_constraint {
 505   my ($self, $cols) = @_;
 506
 507   return join '_', $self->name, @$cols;
 508 }
 509
 510 =head2 unique_constraints
 511
 512 =over 4
 513
 514 =item Arguments: None
 515
 516 =item Return value: Hash of unique constraint data
 517
 518 =back
 519
 520   $source->unique_constraints();
 521
 522 Read-only accessor which returns a hash of unique constraints on this source.
 523
 524 The hash is keyed by constraint name, and contains an arrayref of
 525 column names as values.
 526
 527 =cut
 528
 529 sub unique_constraints {
 530   return %{shift->_unique_constraints||{}};
 531 }
 532
 533 =head2 unique_constraint_names
 534
 535 =over 4
 536
 537 =item Arguments: None
 538
 539 =item Return value: Unique constraint names
 540
 541 =back
 542
 543   $source->unique_constraint_names();
 544
 545 Returns the list of unique constraint names defined on this source.
 546
 547 =cut
 548
 549 sub unique_constraint_names {
 550   my ($self) = @_;
 551
 552   my %unique_constraints = $self->unique_constraints;
 553
 554   return keys %unique_constraints;
 555 }
 556
 557 =head2 unique_constraint_columns
 558
 559 =over 4
 560
 561 =item Arguments: $constraintname
 562
 563 =item Return value: List of constraint columns
 564
 565 =back
 566
 567   $source->unique_constraint_columns('myconstraint');
 568
 569 Returns the list of columns that make up the specified unique constraint.
 570
 571 =cut
 572
 573 sub unique_constraint_columns {
 574   my ($self, $constraint_name) = @_;
 575
 576   my %unique_constraints = $self->unique_constraints;
 577
 578   $self->throw_exception(
 579     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 580   ) unless exists $unique_constraints{$constraint_name};
 581
 582   return @{ $unique_constraints{$constraint_name} };
 583 }
 584
 585 =head2 from
 586
 587 =over 4
 588
 589 =item Arguments: None
 590
 591 =item Return value: FROM clause
 592
 593 =back
 594
 595   my $from_clause = $source->from();
 596
 597 Returns an expression of the source to be supplied to storage to specify
 598 retrieval from this source. In the case of a database, the required FROM
 599 clause contents.
 600
 601 =head2 schema
 602
 603 =over 4
 604
 605 =item Arguments: None
 606
 607 =item Return value: A schema object
 608
 609 =back
 610
 611   my $schema = $source->schema();
 612
 613 Returns the L<DBIx::Class::Schema> object that this result source
 614 belongs to.
 615
 616 =head2 storage
 617
 618 =over 4
 619
 620 =item Arguments: None
 621
 622 =item Return value: A Storage object
 623
 624 =back
 625
 626   $source->storage->debug(1);
 627
 628 Returns the storage handle for the current schema.
 629
 630 See also: L<DBIx::Class::Storage>
 631
 632 =cut
 633
 634 sub storage { shift->schema->storage; }
 635
 636 =head2 add_relationship
 637
 638 =over 4
 639
 640 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
 641
 642 =item Return value: 1/true if it succeeded
 643
 644 =back
 645
 646   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 647
 648 L<DBIx::Class::Relationship> describes a series of methods which
 649 create pre-defined useful types of relationships. Look there first
 650 before using this method directly.
 651
 652 The relationship name can be arbitrary, but must be unique for each
 653 relationship attached to this result source. 'related_source' should
 654 be the name with which the related result source was registered with
 655 the current schema. For example:
 656
 657   $schema->source('Book')->add_relationship('reviews', 'Review', {
 658     'foreign.book_id' => 'self.id',
 659   });
 660
 661 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 662 representation of the join between the tables. For example, if you're
 663 creating a relation from Author to Book,
 664
 665   { 'foreign.author_id' => 'self.id' }
 666
 667 will result in the JOIN clause
 668
 669   author me JOIN book foreign ON foreign.author_id = me.id
 670
 671 You can specify as many foreign => self mappings as necessary.
 672
 673 Valid attributes are as follows:
 674
 675 =over 4
 676
 677 =item join_type
 678
 679 Explicitly specifies the type of join to use in the relationship. Any
 680 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 681 the SQL command immediately before C<JOIN>.
 682
 683 =item proxy
 684
 685 An arrayref containing a list of accessors in the foreign class to proxy in
 686 the main class. If, for example, you do the following:
 687
 688   CD->might_have(liner_notes => 'LinerNotes', undef, {
 689     proxy => [ qw/notes/ ],
 690   });
 691
 692 Then, assuming LinerNotes has an accessor named notes, you can do:
 693
 694   my $cd = CD->find(1);
 695   # set notes -- LinerNotes object is created if it doesn't exist
 696   $cd->notes('Notes go here');
 697
 698 =item accessor
 699
 700 Specifies the type of accessor that should be created for the
 701 relationship. Valid values are C<single> (for when there is only a single
 702 related object), C<multi> (when there can be many), and C<filter> (for
 703 when there is a single related object, but you also want the relationship
 704 accessor to double as a column accessor). For C<multi> accessors, an
 705 add_to_* method is also created, which calls C<create_related> for the
 706 relationship.
 707
 708 =back
 709
 710 Throws an exception if the condition is improperly supplied, or cannot
 711 be resolved using L</resolve_join>.
 712
 713 =cut
 714
 715 sub add_relationship {
 716   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 717   $self->throw_exception("Can't create relationship without join condition")
 718     unless $cond;
 719   $attrs ||= {};
 720
 721   # Check foreign and self are right in cond
 722   if ( (ref $cond ||'') eq 'HASH') {
 723     for (keys %$cond) {
 724       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
 725         if /\./ && !/^foreign\./;
 726     }
 727   }
 728
 729   my %rels = %{ $self->_relationships };
 730   $rels{$rel} = { class => $f_source_name,
 731                   source => $f_source_name,
 732                   cond  => $cond,
 733                   attrs => $attrs };
 734   $self->_relationships(\%rels);
 735
 736   return $self;
 737
 738   # XXX disabled. doesn't work properly currently. skip in tests.
 739
 740   my $f_source = $self->schema->source($f_source_name);
 741   unless ($f_source) {
 742     $self->ensure_class_loaded($f_source_name);
 743     $f_source = $f_source_name->result_source;
 744     #my $s_class = ref($self->schema);
 745     #$f_source_name =~ m/^${s_class}::(.*)$/;
 746     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 747     #$f_source = $self->schema->source($f_source_name);
 748   }
 749   return unless $f_source; # Can't test rel without f_source
 750
 751   eval { $self->resolve_join($rel, 'me') };
 752
 753   if ($@) { # If the resolve failed, back out and re-throw the error
 754     delete $rels{$rel}; #
 755     $self->_relationships(\%rels);
 756     $self->throw_exception("Error creating relationship $rel: $@");
 757   }
 758   1;
 759 }
 760
 761 =head2 relationships
 762
 763 =over 4
 764
 765 =item Arguments: None
 766
 767 =item Return value: List of relationship names
 768
 769 =back
 770
 771   my @relnames = $source->relationships();
 772
 773 Returns all relationship names for this source.
 774
 775 =cut
 776
 777 sub relationships {
 778   return keys %{shift->_relationships};
 779 }
 780
 781 =head2 relationship_info
 782
 783 =over 4
 784
 785 =item Arguments: $relname
 786
 787 =item Return value: Hashref of relation data,
 788
 789 =back
 790
 791 Returns a hash of relationship information for the specified relationship
 792 name. The keys/values are as specified for L</add_relationship>.
 793
 794 =cut
 795
 796 sub relationship_info {
 797   my ($self, $rel) = @_;
 798   return $self->_relationships->{$rel};
 799 }
 800
 801 =head2 has_relationship
 802
 803 =over 4
 804
 805 =item Arguments: $rel
 806
 807 =item Return value: 1/0 (true/false)
 808
 809 =back
 810
 811 Returns true if the source has a relationship of this name, false otherwise.
 812
 813 =cut
 814
 815 sub has_relationship {
 816   my ($self, $rel) = @_;
 817   return exists $self->_relationships->{$rel};
 818 }
 819
 820 =head2 reverse_relationship_info
 821
 822 =over 4
 823
 824 =item Arguments: $relname
 825
 826 =item Return value: Hashref of relationship data
 827
 828 =back
 829
 830 Looks through all the relationships on the source this relationship
 831 points to, looking for one whose condition is the reverse of the
 832 condition on this relationship.
 833
 834 A common use of this is to find the name of the C<belongs_to> relation
 835 opposing a C<has_many> relation. For definition of these look in
 836 L<DBIx::Class::Relationship>.
 837
 838 The returned hashref is keyed by the name of the opposing
 839 relationship, and contains it's data in the same manner as
 840 L</relationship_info>.
 841
 842 =cut
 843
 844 sub reverse_relationship_info {
 845   my ($self, $rel) = @_;
 846   my $rel_info = $self->relationship_info($rel);
 847   my $ret = {};
 848
 849   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 850
 851   my @cond = keys(%{$rel_info->{cond}});
 852   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
 853   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
 854
 855   # Get the related result source for this relationship
 856   my $othertable = $self->related_source($rel);
 857
 858   # Get all the relationships for that source that related to this source
 859   # whose foreign column set are our self columns on $rel and whose self
 860   # columns are our foreign columns on $rel.
 861   my @otherrels = $othertable->relationships();
 862   my $otherrelationship;
 863   foreach my $otherrel (@otherrels) {
 864     my $otherrel_info = $othertable->relationship_info($otherrel);
 865
 866     my $back = $othertable->related_source($otherrel);
 867     next unless $back->source_name eq $self->source_name;
 868
 869     my @othertestconds;
 870
 871     if (ref $otherrel_info->{cond} eq 'HASH') {
 872       @othertestconds = ($otherrel_info->{cond});
 873     }
 874     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
 875       @othertestconds = @{$otherrel_info->{cond}};
 876     }
 877     else {
 878       next;
 879     }
 880
 881     foreach my $othercond (@othertestconds) {
 882       my @other_cond = keys(%$othercond);
 883       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
 884       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
 885       next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
 886                !$self->compare_relationship_keys(\@other_refkeys, \@keys));
 887       $ret->{$otherrel} =  $otherrel_info;
 888     }
 889   }
 890   return $ret;
 891 }
 892
 893 =head2 compare_relationship_keys
 894
 895 =over 4
 896
 897 =item Arguments: \@keys1, \@keys2
 898
 899 =item Return value: 1/0 (true/false)
 900
 901 =back
 902
 903 Returns true if both sets of keynames are the same, false otherwise.
 904
 905 =cut
 906
 907 sub compare_relationship_keys {
 908   my ($self, $keys1, $keys2) = @_;
 909
 910   # Make sure every keys1 is in keys2
 911   my $found;
 912   foreach my $key (@$keys1) {
 913     $found = 0;
 914     foreach my $prim (@$keys2) {
 915       if ($prim eq $key) {
 916         $found = 1;
 917         last;
 918       }
 919     }
 920     last unless $found;
 921   }
 922
 923   # Make sure every key2 is in key1
 924   if ($found) {
 925     foreach my $prim (@$keys2) {
 926       $found = 0;
 927       foreach my $key (@$keys1) {
 928         if ($prim eq $key) {
 929           $found = 1;
 930           last;
 931         }
 932       }
 933       last unless $found;
 934     }
 935   }
 936
 937   return $found;
 938 }
 939
 940 =head2 resolve_join
 941
 942 =over 4
 943
 944 =item Arguments: $relation
 945
 946 =item Return value: Join condition arrayref
 947
 948 =back
 949
 950 Returns the join structure required for the related result source.
 951
 952 =cut
 953
 954 sub resolve_join {
 955   my ($self, $join, $alias, $seen, $force_left) = @_;
 956   $seen ||= {};
 957   $force_left ||= { force => 0 };
 958   if (ref $join eq 'ARRAY') {
 959     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 960   } elsif (ref $join eq 'HASH') {
 961     return
 962       map {
 963         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 964         local $force_left->{force};
 965         (
 966           $self->resolve_join($_, $alias, $seen, $force_left),
 967           $self->related_source($_)->resolve_join(
 968             $join->{$_}, $as, $seen, $force_left
 969           )
 970         );
 971       } keys %$join;
 972   } elsif (ref $join) {
 973     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 974   } else {
 975     my $count = ++$seen->{$join};
 976     #use Data::Dumper; warn Dumper($seen);
 977     my $as = ($count > 1 ? "${join}_${count}" : $join);
 978     my $rel_info = $self->relationship_info($join);
 979     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 980     my $type;
 981     if ($force_left->{force}) {
 982       $type = 'left';
 983     } else {
 984       $type = $rel_info->{attrs}{join_type} || '';
 985       $force_left->{force} = 1 if lc($type) eq 'left';
 986     }
 987     return [ { $as => $self->related_source($join)->from,
 988                -join_type => $type },
 989              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 990   }
 991 }
 992
 993 =head2 pk_depends_on
 994
 995 =over 4
 996
 997 =item Arguments: $relname, $rel_data
 998
 999 =item Return value: 1/0 (true/false)
1000
1001 =back
1002
1003 Determines whether a relation is dependent on an object from this source
1004 having already been inserted. Takes the name of the relationship and a
1005 hashref of columns of the related object.
1006
1007 =cut
1008
1009 sub pk_depends_on {
1010   my ($self, $relname, $rel_data) = @_;
1011   my $cond = $self->relationship_info($relname)->{cond};
1012
1013   return 0 unless ref($cond) eq 'HASH';
1014
1015   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1016
1017   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1018
1019   # assume anything that references our PK probably is dependent on us
1020   # rather than vice versa, unless the far side is (a) defined or (b)
1021   # auto-increment
1022
1023   my $rel_source = $self->related_source($relname);
1024
1025   foreach my $p ($self->primary_columns) {
1026     if (exists $keyhash->{$p}) {
1027       unless (defined($rel_data->{$keyhash->{$p}})
1028               || $rel_source->column_info($keyhash->{$p})
1029                             ->{is_auto_increment}) {
1030         return 0;
1031       }
1032     }
1033   }
1034
1035   return 1;
1036 }
1037
1038 =head2 resolve_condition
1039
1040 =over 4
1041
1042 =item Arguments: $cond, $as, $alias|$object
1043
1044 =back
1045
1046 Resolves the passed condition to a concrete query fragment. If given an alias,
1047 returns a join condition; if given an object, inverts that object to produce
1048 a related conditional from that object.
1049
1050 =cut
1051
1052 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1053
1054 sub resolve_condition {
1055   my ($self, $cond, $as, $for) = @_;
1056   #warn %$cond;
1057   if (ref $cond eq 'HASH') {
1058     my %ret;
1059     foreach my $k (keys %{$cond}) {
1060       my $v = $cond->{$k};
1061       # XXX should probably check these are valid columns
1062       $k =~ s/^foreign\.// ||
1063         $self->throw_exception("Invalid rel cond key ${k}");
1064       $v =~ s/^self\.// ||
1065         $self->throw_exception("Invalid rel cond val ${v}");
1066       if (ref $for) { # Object
1067         #warn "$self $k $for $v";
1068         unless ($for->has_column_loaded($v)) {
1069           if ($for->in_storage) {
1070             $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
1071           }
1072           return $UNRESOLVABLE_CONDITION;
1073         }
1074         $ret{$k} = $for->get_column($v);
1075         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1076         #warn %ret;
1077       } elsif (!defined $for) { # undef, i.e. "no object"
1078         $ret{$k} = undef;
1079       } elsif (ref $as eq 'HASH') { # reverse hashref
1080         $ret{$v} = $as->{$k};
1081       } elsif (ref $as) { # reverse object
1082         $ret{$v} = $as->get_column($k);
1083       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1084         $ret{$v} = undef;
1085       } else {
1086         $ret{"${as}.${k}"} = "${for}.${v}";
1087       }
1088     }
1089     return \%ret;
1090   } elsif (ref $cond eq 'ARRAY') {
1091     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1092   } else {
1093    die("Can't handle this yet :(");
1094   }
1095 }
1096
1097 =head2 resolve_prefetch
1098
1099 =over 4
1100
1101 =item Arguments: hashref/arrayref/scalar
1102
1103 =back
1104
1105 Accepts one or more relationships for the current source and returns an
1106 array of column names for each of those relationships. Column names are
1107 prefixed relative to the current source, in accordance with where they appear
1108 in the supplied relationships. Examples:
1109
1110   my $source = $schema->resultset('Tag')->source;
1111   @columns = $source->resolve_prefetch( { cd => 'artist' } );
1112
1113   # @columns =
1114   #(
1115   #  'cd.cdid',
1116   #  'cd.artist',
1117   #  'cd.title',
1118   #  'cd.year',
1119   #  'cd.artist.artistid',
1120   #  'cd.artist.name'
1121   #)
1122
1123   @columns = $source->resolve_prefetch( qw[/ cd /] );
1124
1125   # @columns =
1126   #(
1127   #   'cd.cdid',
1128   #   'cd.artist',
1129   #   'cd.title',
1130   #   'cd.year'
1131   #)
1132
1133   $source = $schema->resultset('CD')->source;
1134   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1135
1136   # @columns =
1137   #(
1138   #  'artist.artistid',
1139   #  'artist.name',
1140   #  'producer.producerid',
1141   #  'producer.name'
1142   #)
1143
1144 =cut
1145
1146 sub resolve_prefetch {
1147   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1148   $seen ||= {};
1149   #$alias ||= $self->name;
1150   #warn $alias, Dumper $pre;
1151   if( ref $pre eq 'ARRAY' ) {
1152     return
1153       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1154         @$pre;
1155   }
1156   elsif( ref $pre eq 'HASH' ) {
1157     my @ret =
1158     map {
1159       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1160       $self->related_source($_)->resolve_prefetch(
1161                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1162     } keys %$pre;
1163     #die Dumper \@ret;
1164     return @ret;
1165   }
1166   elsif( ref $pre ) {
1167     $self->throw_exception(
1168       "don't know how to resolve prefetch reftype ".ref($pre));
1169   }
1170   else {
1171     my $count = ++$seen->{$pre};
1172     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1173     my $rel_info = $self->relationship_info( $pre );
1174     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1175       unless $rel_info;
1176     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1177     my $rel_source = $self->related_source($pre);
1178
1179     if (exists $rel_info->{attrs}{accessor}
1180          && $rel_info->{attrs}{accessor} eq 'multi') {
1181       $self->throw_exception(
1182         "Can't prefetch has_many ${pre} (join cond too complex)")
1183         unless ref($rel_info->{cond}) eq 'HASH';
1184       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1185       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1186                          keys %{$collapse}) {
1187         my ($last) = ($fail =~ /([^\.]+)$/);
1188         carp (
1189           "Prefetching multiple has_many rels ${last} and ${pre} "
1190           .(length($as_prefix)
1191             ? "at the same level (${as_prefix}) "
1192             : "at top level "
1193           )
1194           . 'will currently disrupt both the functionality of $rs->count(), '
1195           . 'and the amount of objects retrievable via $rs->next(). '
1196           . 'Use at your own risk.'
1197         );
1198       }
1199       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1200       #              values %{$rel_info->{cond}};
1201       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1202         # action at a distance. prepending the '.' allows simpler code
1203         # in ResultSet->_collapse_result
1204       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1205                     keys %{$rel_info->{cond}};
1206       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1207                    ? @{$rel_info->{attrs}{order_by}}
1208                    : (defined $rel_info->{attrs}{order_by}
1209                        ? ($rel_info->{attrs}{order_by})
1210                        : ()));
1211       push(@$order, map { "${as}.$_" } (@key, @ord));
1212     }
1213
1214     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1215       $rel_source->columns;
1216     #warn $alias, Dumper (\@ret);
1217     #return @ret;
1218   }
1219 }
1220
1221 =head2 related_source
1222
1223 =over 4
1224
1225 =item Arguments: $relname
1226
1227 =item Return value: $source
1228
1229 =back
1230
1231 Returns the result source object for the given relationship.
1232
1233 =cut
1234
1235 sub related_source {
1236   my ($self, $rel) = @_;
1237   if( !$self->has_relationship( $rel ) ) {
1238     $self->throw_exception("No such relationship '$rel'");
1239   }
1240   return $self->schema->source($self->relationship_info($rel)->{source});
1241 }
1242
1243 =head2 related_class
1244
1245 =over 4
1246
1247 =item Arguments: $relname
1248
1249 =item Return value: $classname
1250
1251 =back
1252
1253 Returns the class name for objects in the given relationship.
1254
1255 =cut
1256
1257 sub related_class {
1258   my ($self, $rel) = @_;
1259   if( !$self->has_relationship( $rel ) ) {
1260     $self->throw_exception("No such relationship '$rel'");
1261   }
1262   return $self->schema->class($self->relationship_info($rel)->{source});
1263 }
1264
1265 =head2 resultset
1266
1267 =over 4
1268
1269 =item Arguments: None
1270
1271 =item Return value: $resultset
1272
1273 =back
1274
1275 Returns a resultset for the given source. This will initially be created
1276 on demand by calling
1277
1278   $self->resultset_class->new($self, $self->resultset_attributes)
1279
1280 but is cached from then on unless resultset_class changes.
1281
1282 =head2 resultset_class
1283
1284 =over 4
1285
1286 =item Arguments: $classname
1287
1288 =item Return value: $classname
1289
1290 =back
1291
1292   package My::ResultSetClass;
1293   use base 'DBIx::Class::ResultSet';
1294   ...
1295
1296   $source->resultset_class('My::ResultSet::Class');
1297
1298 Set the class of the resultset, this is useful if you want to create your
1299 own resultset methods. Create your own class derived from
1300 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1301 this method returns the name of the existing resultset class, if one
1302 exists.
1303
1304 =head2 resultset_attributes
1305
1306 =over 4
1307
1308 =item Arguments: \%attrs
1309
1310 =item Return value: \%attrs
1311
1312 =back
1313
1314   $source->resultset_attributes({ order_by => [ 'id' ] });
1315
1316 Store a collection of resultset attributes, that will be set on every
1317 L<DBIx::Class::ResultSet> produced from this result source. For a full
1318 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
1319
1320 =cut
1321
1322 sub resultset {
1323   my $self = shift;
1324   $self->throw_exception(
1325     'resultset does not take any arguments. If you want another resultset, '.
1326     'call it on the schema instead.'
1327   ) if scalar @_;
1328
1329   return $self->resultset_class->new(
1330     $self,
1331     {
1332       %{$self->{resultset_attributes}},
1333       %{$self->schema->default_resultset_attributes}
1334     },
1335   );
1336 }
1337
1338 =head2 source_name
1339
1340 =over 4
1341
1342 =item Arguments: $source_name
1343
1344 =item Result value: $source_name
1345
1346 =back
1347
1348 Set an alternate name for the result source when it is loaded into a schema.
1349 This is useful if you want to refer to a result source by a name other than
1350 its class name.
1351
1352   package ArchivedBooks;
1353   use base qw/DBIx::Class/;
1354   __PACKAGE__->table('books_archive');
1355   __PACKAGE__->source_name('Books');
1356
1357   # from your schema...
1358   $schema->resultset('Books')->find(1);
1359
1360 =head2 handle
1361
1362 Obtain a new handle to this source. Returns an instance of a
1363 L<DBIx::Class::ResultSourceHandle>.
1364
1365 =cut
1366
1367 sub handle {
1368     return new DBIx::Class::ResultSourceHandle({
1369         schema         => $_[0]->schema,
1370         source_moniker => $_[0]->source_name
1371     });
1372 }
1373
1374 =head2 throw_exception
1375
1376 See L<DBIx::Class::Schema/"throw_exception">.
1377
1378 =cut
1379
1380 sub throw_exception {
1381   my $self = shift;
1382   if (defined $self->schema) {
1383     $self->schema->throw_exception(@_);
1384   } else {
1385     croak(@_);
1386   }
1387 }
1388
1389 =head2 sqlt_deploy_hook($sqlt_table)
1390
1391 =over 4
1392
1393 =item Arguments: $source, $sqlt_table
1394
1395 =item Return value: undefined
1396
1397 =back
1398
1399 An optional sub which you can declare in your own Result class that will get
1400 passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1401 via L</create_ddl_dir> or L</deploy>.
1402
1403 This is useful to make L<SQL::Translator> create non-unique indexes,
1404 or set table options such as C<Engine=INNOFB>.
1405
1406 For an example of what you can do with this, see
1407 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1408
1409 =head1 AUTHORS
1410
1411 Matt S. Trout <mst@shadowcatsystems.co.uk>
1412
1413 =head1 LICENSE
1414
1415 You may distribute this code under the same terms as Perl itself.
1416
1417 =cut
1418
1419 1;