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 C<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 using L</resolve_join>.
 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 =head2 compare_relationship_keys
1027
1028 =over 4
1029
1030 =item Arguments: \@keys1, \@keys2
1031
1032 =item Return value: 1/0 (true/false)
1033
1034 =back
1035
1036 Returns true if both sets of keynames are the same, false otherwise.
1037
1038 =cut
1039
1040 sub compare_relationship_keys {
1041   my ($self, $keys1, $keys2) = @_;
1042
1043   # Make sure every keys1 is in keys2
1044   my $found;
1045   foreach my $key (@$keys1) {
1046     $found = 0;
1047     foreach my $prim (@$keys2) {
1048       if ($prim eq $key) {
1049         $found = 1;
1050         last;
1051       }
1052     }
1053     last unless $found;
1054   }
1055
1056   # Make sure every key2 is in key1
1057   if ($found) {
1058     foreach my $prim (@$keys2) {
1059       $found = 0;
1060       foreach my $key (@$keys1) {
1061         if ($prim eq $key) {
1062           $found = 1;
1063           last;
1064         }
1065       }
1066       last unless $found;
1067     }
1068   }
1069
1070   return $found;
1071 }
1072
1073 =head2 resolve_join
1074
1075 =over 4
1076
1077 =item Arguments: $relation
1078
1079 =item Return value: Join condition arrayref
1080
1081 =back
1082
1083 Returns the join structure required for the related result source.
1084
1085 =cut
1086
1087 sub resolve_join {
1088   my ($self, $join, $alias, $seen, $force_left) = @_;
1089   $seen ||= {};
1090   $force_left ||= { force => 0 };
1091   if (ref $join eq 'ARRAY') {
1092     return
1093       map {
1094         local $force_left->{force} = $force_left->{force};
1095         $self->resolve_join($_, $alias, $seen, $force_left);
1096       } @$join;
1097   } elsif (ref $join eq 'HASH') {
1098     return
1099       map {
1100         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
1101         local $force_left->{force} = $force_left->{force};
1102         (
1103           $self->resolve_join($_, $alias, $seen, $force_left),
1104           $self->related_source($_)->resolve_join(
1105             $join->{$_}, $as, $seen, $force_left
1106           )
1107         );
1108       } keys %$join;
1109   } elsif (ref $join) {
1110     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1111   } else {
1112     my $count = ++$seen->{$join};
1113     #use Data::Dumper; warn Dumper($seen);
1114     my $as = ($count > 1 ? "${join}_${count}" : $join);
1115     my $rel_info = $self->relationship_info($join);
1116     $self->throw_exception("No such relationship ${join}") unless $rel_info;
1117     my $type;
1118     if ($force_left->{force}) {
1119       $type = 'left';
1120     } else {
1121       $type = $rel_info->{attrs}{join_type} || '';
1122       $force_left->{force} = 1 if lc($type) eq 'left';
1123     }
1124     return [ { $as => $self->related_source($join)->from,
1125                -join_type => $type },
1126              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
1127   }
1128 }
1129
1130 =head2 pk_depends_on
1131
1132 =over 4
1133
1134 =item Arguments: $relname, $rel_data
1135
1136 =item Return value: 1/0 (true/false)
1137
1138 =back
1139
1140 Determines whether a relation is dependent on an object from this source
1141 having already been inserted. Takes the name of the relationship and a
1142 hashref of columns of the related object.
1143
1144 =cut
1145
1146 sub pk_depends_on {
1147   my ($self, $relname, $rel_data) = @_;
1148   my $cond = $self->relationship_info($relname)->{cond};
1149
1150   return 0 unless ref($cond) eq 'HASH';
1151
1152   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1153
1154   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1155
1156   # assume anything that references our PK probably is dependent on us
1157   # rather than vice versa, unless the far side is (a) defined or (b)
1158   # auto-increment
1159
1160   my $rel_source = $self->related_source($relname);
1161
1162   foreach my $p ($self->primary_columns) {
1163     if (exists $keyhash->{$p}) {
1164       unless (defined($rel_data->{$keyhash->{$p}})
1165               || $rel_source->column_info($keyhash->{$p})
1166                             ->{is_auto_increment}) {
1167         return 0;
1168       }
1169     }
1170   }
1171
1172   return 1;
1173 }
1174
1175 =head2 resolve_condition
1176
1177 =over 4
1178
1179 =item Arguments: $cond, $as, $alias|$object
1180
1181 =back
1182
1183 Resolves the passed condition to a concrete query fragment. If given an alias,
1184 returns a join condition; if given an object, inverts that object to produce
1185 a related conditional from that object.
1186
1187 =cut
1188
1189 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1190
1191 sub resolve_condition {
1192   my ($self, $cond, $as, $for) = @_;
1193   #warn %$cond;
1194   if (ref $cond eq 'HASH') {
1195     my %ret;
1196     foreach my $k (keys %{$cond}) {
1197       my $v = $cond->{$k};
1198       # XXX should probably check these are valid columns
1199       $k =~ s/^foreign\.// ||
1200         $self->throw_exception("Invalid rel cond key ${k}");
1201       $v =~ s/^self\.// ||
1202         $self->throw_exception("Invalid rel cond val ${v}");
1203       if (ref $for) { # Object
1204         #warn "$self $k $for $v";
1205         unless ($for->has_column_loaded($v)) {
1206           if ($for->in_storage) {
1207             $self->throw_exception(
1208               "Column ${v} not loaded or not passed to new() prior to insert()"
1209                 ." on ${for} trying to resolve relationship (maybe you forgot "
1210                   ."to call ->reload_from_storage to get defaults from the db)"
1211             );
1212           }
1213           return $UNRESOLVABLE_CONDITION;
1214         }
1215         $ret{$k} = $for->get_column($v);
1216         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1217         #warn %ret;
1218       } elsif (!defined $for) { # undef, i.e. "no object"
1219         $ret{$k} = undef;
1220       } elsif (ref $as eq 'HASH') { # reverse hashref
1221         $ret{$v} = $as->{$k};
1222       } elsif (ref $as) { # reverse object
1223         $ret{$v} = $as->get_column($k);
1224       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1225         $ret{$v} = undef;
1226       } else {
1227         $ret{"${as}.${k}"} = "${for}.${v}";
1228       }
1229     }
1230     return \%ret;
1231   } elsif (ref $cond eq 'ARRAY') {
1232     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1233   } else {
1234    die("Can't handle this yet :(");
1235   }
1236 }
1237
1238 =head2 resolve_prefetch
1239
1240 =over 4
1241
1242 =item Arguments: hashref/arrayref/scalar
1243
1244 =back
1245
1246 Accepts one or more relationships for the current source and returns an
1247 array of column names for each of those relationships. Column names are
1248 prefixed relative to the current source, in accordance with where they appear
1249 in the supplied relationships. Examples:
1250
1251   my $source = $schema->resultset('Tag')->source;
1252   @columns = $source->resolve_prefetch( { cd => 'artist' } );
1253
1254   # @columns =
1255   #(
1256   #  'cd.cdid',
1257   #  'cd.artist',
1258   #  'cd.title',
1259   #  'cd.year',
1260   #  'cd.artist.artistid',
1261   #  'cd.artist.name'
1262   #)
1263
1264   @columns = $source->resolve_prefetch( qw[/ cd /] );
1265
1266   # @columns =
1267   #(
1268   #   'cd.cdid',
1269   #   'cd.artist',
1270   #   'cd.title',
1271   #   'cd.year'
1272   #)
1273
1274   $source = $schema->resultset('CD')->source;
1275   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1276
1277   # @columns =
1278   #(
1279   #  'artist.artistid',
1280   #  'artist.name',
1281   #  'producer.producerid',
1282   #  'producer.name'
1283   #)
1284
1285 =cut
1286
1287 sub resolve_prefetch {
1288   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1289   $seen ||= {};
1290   #$alias ||= $self->name;
1291   #warn $alias, Dumper $pre;
1292   if( ref $pre eq 'ARRAY' ) {
1293     return
1294       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1295         @$pre;
1296   }
1297   elsif( ref $pre eq 'HASH' ) {
1298     my @ret =
1299     map {
1300       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1301       $self->related_source($_)->resolve_prefetch(
1302                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1303     } keys %$pre;
1304     #die Dumper \@ret;
1305     return @ret;
1306   }
1307   elsif( ref $pre ) {
1308     $self->throw_exception(
1309       "don't know how to resolve prefetch reftype ".ref($pre));
1310   }
1311   else {
1312     my $count = ++$seen->{$pre};
1313     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1314     my $rel_info = $self->relationship_info( $pre );
1315     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1316       unless $rel_info;
1317     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1318     my $rel_source = $self->related_source($pre);
1319
1320     if (exists $rel_info->{attrs}{accessor}
1321          && $rel_info->{attrs}{accessor} eq 'multi') {
1322       $self->throw_exception(
1323         "Can't prefetch has_many ${pre} (join cond too complex)")
1324         unless ref($rel_info->{cond}) eq 'HASH';
1325       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1326       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1327                          keys %{$collapse}) {
1328         my ($last) = ($fail =~ /([^\.]+)$/);
1329         carp (
1330           "Prefetching multiple has_many rels ${last} and ${pre} "
1331           .(length($as_prefix)
1332             ? "at the same level (${as_prefix}) "
1333             : "at top level "
1334           )
1335           . 'will currently disrupt both the functionality of $rs->count(), '
1336           . 'and the amount of objects retrievable via $rs->next(). '
1337           . 'Use at your own risk.'
1338         );
1339       }
1340       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1341       #              values %{$rel_info->{cond}};
1342       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1343         # action at a distance. prepending the '.' allows simpler code
1344         # in ResultSet->_collapse_result
1345       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1346                     keys %{$rel_info->{cond}};
1347       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1348                    ? @{$rel_info->{attrs}{order_by}}
1349                    : (defined $rel_info->{attrs}{order_by}
1350                        ? ($rel_info->{attrs}{order_by})
1351                        : ()));
1352       push(@$order, map { "${as}.$_" } (@key, @ord));
1353     }
1354
1355     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1356       $rel_source->columns;
1357     #warn $alias, Dumper (\@ret);
1358     #return @ret;
1359   }
1360 }
1361
1362 =head2 related_source
1363
1364 =over 4
1365
1366 =item Arguments: $relname
1367
1368 =item Return value: $source
1369
1370 =back
1371
1372 Returns the result source object for the given relationship.
1373
1374 =cut
1375
1376 sub related_source {
1377   my ($self, $rel) = @_;
1378   if( !$self->has_relationship( $rel ) ) {
1379     $self->throw_exception("No such relationship '$rel'");
1380   }
1381   return $self->schema->source($self->relationship_info($rel)->{source});
1382 }
1383
1384 =head2 related_class
1385
1386 =over 4
1387
1388 =item Arguments: $relname
1389
1390 =item Return value: $classname
1391
1392 =back
1393
1394 Returns the class name for objects in the given relationship.
1395
1396 =cut
1397
1398 sub related_class {
1399   my ($self, $rel) = @_;
1400   if( !$self->has_relationship( $rel ) ) {
1401     $self->throw_exception("No such relationship '$rel'");
1402   }
1403   return $self->schema->class($self->relationship_info($rel)->{source});
1404 }
1405
1406 =head2 handle
1407
1408 Obtain a new handle to this source. Returns an instance of a
1409 L<DBIx::Class::ResultSourceHandle>.
1410
1411 =cut
1412
1413 sub handle {
1414     return new DBIx::Class::ResultSourceHandle({
1415         schema         => $_[0]->schema,
1416         source_moniker => $_[0]->source_name
1417     });
1418 }
1419
1420 =head2 throw_exception
1421
1422 See L<DBIx::Class::Schema/"throw_exception">.
1423
1424 =cut
1425
1426 sub throw_exception {
1427   my $self = shift;
1428   if (defined $self->schema) {
1429     $self->schema->throw_exception(@_);
1430   } else {
1431     croak(@_);
1432   }
1433 }
1434
1435 =head2 source_info
1436
1437 Stores a hashref of per-source metadata.  No specific key names
1438 have yet been standardized, the examples below are purely hypothetical
1439 and don't actually accomplish anything on their own:
1440
1441   __PACKAGE__->source_info({
1442     "_tablespace" => 'fast_disk_array_3',
1443     "_engine" => 'InnoDB',
1444   });
1445
1446 =head2 new
1447
1448   $class->new();
1449
1450   $class->new({attribute_name => value});
1451
1452 Creates a new ResultSource object.  Not normally called directly by end users.
1453
1454 =head2 column_info_from_storage
1455
1456 =over
1457
1458 =item Arguments: 1/0 (default: 0)
1459
1460 =item Return value: 1/0
1461
1462 =back
1463
1464   __PACKAGE__->column_info_from_storage(1);
1465
1466 Enables the on-demand automatic loading of the above column
1467 metadata from storage as neccesary.  This is *deprecated*, and
1468 should not be used.  It will be removed before 1.0.
1469
1470
1471 =head1 AUTHORS
1472
1473 Matt S. Trout <mst@shadowcatsystems.co.uk>
1474
1475 =head1 LICENSE
1476
1477 You may distribute this code under the same terms as Perl itself.
1478
1479 =cut
1480
1481 1;