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