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