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   my $name = $self->name;
 488   $name = $$name if ref $name;
 489
 490   return join '_', $name, @$cols;
 491 }
 492
 493 =head2 unique_constraints
 494
 495 =over 4
 496
 497 =item Arguments: None
 498
 499 =item Return value: Hash of unique constraint data
 500
 501 =back
 502
 503   $source->unique_constraints();
 504
 505 Read-only accessor which returns a hash of unique constraints on this source.
 506
 507 The hash is keyed by constraint name, and contains an arrayref of
 508 column names as values.
 509
 510 =cut
 511
 512 sub unique_constraints {
 513   return %{shift->_unique_constraints||{}};
 514 }
 515
 516 =head2 unique_constraint_names
 517
 518 =over 4
 519
 520 =item Arguments: None
 521
 522 =item Return value: Unique constraint names
 523
 524 =back
 525
 526   $source->unique_constraint_names();
 527
 528 Returns the list of unique constraint names defined on this source.
 529
 530 =cut
 531
 532 sub unique_constraint_names {
 533   my ($self) = @_;
 534
 535   my %unique_constraints = $self->unique_constraints;
 536
 537   return keys %unique_constraints;
 538 }
 539
 540 =head2 unique_constraint_columns
 541
 542 =over 4
 543
 544 =item Arguments: $constraintname
 545
 546 =item Return value: List of constraint columns
 547
 548 =back
 549
 550   $source->unique_constraint_columns('myconstraint');
 551
 552 Returns the list of columns that make up the specified unique constraint.
 553
 554 =cut
 555
 556 sub unique_constraint_columns {
 557   my ($self, $constraint_name) = @_;
 558
 559   my %unique_constraints = $self->unique_constraints;
 560
 561   $self->throw_exception(
 562     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 563   ) unless exists $unique_constraints{$constraint_name};
 564
 565   return @{ $unique_constraints{$constraint_name} };
 566 }
 567
 568 =head2 sqlt_deploy_callback
 569
 570 =over
 571
 572 =item Arguments: $callback
 573
 574 =back
 575
 576   __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
 577
 578 An accessor to set a callback to be called during deployment of
 579 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
 580 L<DBIx::Class::Schema/deploy>.
 581
 582 The callback can be set as either a code reference or the name of a
 583 method in the current result class.
 584
 585 If not set, the L</default_sqlt_deploy_hook> is called.
 586
 587 Your callback will be passed the $source object representing the
 588 ResultSource instance being deployed, and the
 589 L<SQL::Translator::Schema::Table> object being created from it. The
 590 callback can be used to manipulate the table object or add your own
 591 customised indexes. If you need to manipulate a non-table object, use
 592 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
 593
 594 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
 595 Your SQL> for examples.
 596
 597 This sqlt deployment callback can only be used to manipulate
 598 SQL::Translator objects as they get turned into SQL. To execute
 599 post-deploy statements which SQL::Translator does not currently
 600 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
 601 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
 602
 603 =head2 default_sqlt_deploy_hook
 604
 605 =over
 606
 607 =item Arguments: $source, $sqlt_table
 608
 609 =item Return value: undefined
 610
 611 =back
 612
 613 This is the sensible default for L</sqlt_deploy_callback>.
 614
 615 If a method named C<sqlt_deploy_hook> exists in your Result class, it
 616 will be called and passed the current C<$source> and the
 617 C<$sqlt_table> being deployed.
 618
 619 =cut
 620
 621 sub default_sqlt_deploy_hook {
 622   my $self = shift;
 623
 624   my $class = $self->result_class;
 625
 626   if ($class and $class->can('sqlt_deploy_hook')) {
 627     $class->sqlt_deploy_hook(@_);
 628   }
 629 }
 630
 631 sub _invoke_sqlt_deploy_hook {
 632   my $self = shift;
 633   if ( my $hook = $self->sqlt_deploy_callback) {
 634     $self->$hook(@_);
 635   }
 636 }
 637
 638 =head2 resultset
 639
 640 =over 4
 641
 642 =item Arguments: None
 643
 644 =item Return value: $resultset
 645
 646 =back
 647
 648 Returns a resultset for the given source. This will initially be created
 649 on demand by calling
 650
 651   $self->resultset_class->new($self, $self->resultset_attributes)
 652
 653 but is cached from then on unless resultset_class changes.
 654
 655 =head2 resultset_class
 656
 657 =over 4
 658
 659 =item Arguments: $classname
 660
 661 =item Return value: $classname
 662
 663 =back
 664
 665   package My::ResultSetClass;
 666   use base 'DBIx::Class::ResultSet';
 667   ...
 668
 669   $source->resultset_class('My::ResultSet::Class');
 670
 671 Set the class of the resultset. This is useful if you want to create your
 672 own resultset methods. Create your own class derived from
 673 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
 674 this method returns the name of the existing resultset class, if one
 675 exists.
 676
 677 =head2 resultset_attributes
 678
 679 =over 4
 680
 681 =item Arguments: \%attrs
 682
 683 =item Return value: \%attrs
 684
 685 =back
 686
 687   $source->resultset_attributes({ order_by => [ 'id' ] });
 688
 689 Store a collection of resultset attributes, that will be set on every
 690 L<DBIx::Class::ResultSet> produced from this result source. For a full
 691 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
 692
 693 =cut
 694
 695 sub resultset {
 696   my $self = shift;
 697   $self->throw_exception(
 698     'resultset does not take any arguments. If you want another resultset, '.
 699     'call it on the schema instead.'
 700   ) if scalar @_;
 701
 702   return $self->resultset_class->new(
 703     $self,
 704     {
 705       %{$self->{resultset_attributes}},
 706       %{$self->schema->default_resultset_attributes}
 707     },
 708   );
 709 }
 710
 711 =head2 source_name
 712
 713 =over 4
 714
 715 =item Arguments: $source_name
 716
 717 =item Result value: $source_name
 718
 719 =back
 720
 721 Set an alternate name for the result source when it is loaded into a schema.
 722 This is useful if you want to refer to a result source by a name other than
 723 its class name.
 724
 725   package ArchivedBooks;
 726   use base qw/DBIx::Class/;
 727   __PACKAGE__->table('books_archive');
 728   __PACKAGE__->source_name('Books');
 729
 730   # from your schema...
 731   $schema->resultset('Books')->find(1);
 732
 733 =head2 from
 734
 735 =over 4
 736
 737 =item Arguments: None
 738
 739 =item Return value: FROM clause
 740
 741 =back
 742
 743   my $from_clause = $source->from();
 744
 745 Returns an expression of the source to be supplied to storage to specify
 746 retrieval from this source. In the case of a database, the required FROM
 747 clause contents.
 748
 749 =head2 schema
 750
 751 =over 4
 752
 753 =item Arguments: None
 754
 755 =item Return value: A schema object
 756
 757 =back
 758
 759   my $schema = $source->schema();
 760
 761 Returns the L<DBIx::Class::Schema> object that this result source
 762 belongs to.
 763
 764 =head2 storage
 765
 766 =over 4
 767
 768 =item Arguments: None
 769
 770 =item Return value: A Storage object
 771
 772 =back
 773
 774   $source->storage->debug(1);
 775
 776 Returns the storage handle for the current schema.
 777
 778 See also: L<DBIx::Class::Storage>
 779
 780 =cut
 781
 782 sub storage { shift->schema->storage; }
 783
 784 =head2 add_relationship
 785
 786 =over 4
 787
 788 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
 789
 790 =item Return value: 1/true if it succeeded
 791
 792 =back
 793
 794   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 795
 796 L<DBIx::Class::Relationship> describes a series of methods which
 797 create pre-defined useful types of relationships. Look there first
 798 before using this method directly.
 799
 800 The relationship name can be arbitrary, but must be unique for each
 801 relationship attached to this result source. 'related_source' should
 802 be the name with which the related result source was registered with
 803 the current schema. For example:
 804
 805   $schema->source('Book')->add_relationship('reviews', 'Review', {
 806     'foreign.book_id' => 'self.id',
 807   });
 808
 809 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 810 representation of the join between the tables. For example, if you're
 811 creating a relation from Author to Book,
 812
 813   { 'foreign.author_id' => 'self.id' }
 814
 815 will result in the JOIN clause
 816
 817   author me JOIN book foreign ON foreign.author_id = me.id
 818
 819 You can specify as many foreign => self mappings as necessary.
 820
 821 Valid attributes are as follows:
 822
 823 =over 4
 824
 825 =item join_type
 826
 827 Explicitly specifies the type of join to use in the relationship. Any
 828 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 829 the SQL command immediately before C<JOIN>.
 830
 831 =item proxy
 832
 833 An arrayref containing a list of accessors in the foreign class to proxy in
 834 the main class. If, for example, you do the following:
 835
 836   CD->might_have(liner_notes => 'LinerNotes', undef, {
 837     proxy => [ qw/notes/ ],
 838   });
 839
 840 Then, assuming LinerNotes has an accessor named notes, you can do:
 841
 842   my $cd = CD->find(1);
 843   # set notes -- LinerNotes object is created if it doesn't exist
 844   $cd->notes('Notes go here');
 845
 846 =item accessor
 847
 848 Specifies the type of accessor that should be created for the
 849 relationship. Valid values are C<single> (for when there is only a single
 850 related object), C<multi> (when there can be many), and C<filter> (for
 851 when there is a single related object, but you also want the relationship
 852 accessor to double as a column accessor). For C<multi> accessors, an
 853 add_to_* method is also created, which calls C<create_related> for the
 854 relationship.
 855
 856 =back
 857
 858 Throws an exception if the condition is improperly supplied, or cannot
 859 be resolved.
 860
 861 =cut
 862
 863 sub add_relationship {
 864   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 865   $self->throw_exception("Can't create relationship without join condition")
 866     unless $cond;
 867   $attrs ||= {};
 868
 869   # Check foreign and self are right in cond
 870   if ( (ref $cond ||'') eq 'HASH') {
 871     for (keys %$cond) {
 872       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
 873         if /\./ && !/^foreign\./;
 874     }
 875   }
 876
 877   my %rels = %{ $self->_relationships };
 878   $rels{$rel} = { class => $f_source_name,
 879                   source => $f_source_name,
 880                   cond  => $cond,
 881                   attrs => $attrs };
 882   $self->_relationships(\%rels);
 883
 884   return $self;
 885
 886   # XXX disabled. doesn't work properly currently. skip in tests.
 887
 888   my $f_source = $self->schema->source($f_source_name);
 889   unless ($f_source) {
 890     $self->ensure_class_loaded($f_source_name);
 891     $f_source = $f_source_name->result_source;
 892     #my $s_class = ref($self->schema);
 893     #$f_source_name =~ m/^${s_class}::(.*)$/;
 894     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 895     #$f_source = $self->schema->source($f_source_name);
 896   }
 897   return unless $f_source; # Can't test rel without f_source
 898
 899   eval { $self->_resolve_join($rel, 'me', {}, []) };
 900
 901   if ($@) { # If the resolve failed, back out and re-throw the error
 902     delete $rels{$rel}; #
 903     $self->_relationships(\%rels);
 904     $self->throw_exception("Error creating relationship $rel: $@");
 905   }
 906   1;
 907 }
 908
 909 =head2 relationships
 910
 911 =over 4
 912
 913 =item Arguments: None
 914
 915 =item Return value: List of relationship names
 916
 917 =back
 918
 919   my @relnames = $source->relationships();
 920
 921 Returns all relationship names for this source.
 922
 923 =cut
 924
 925 sub relationships {
 926   return keys %{shift->_relationships};
 927 }
 928
 929 =head2 relationship_info
 930
 931 =over 4
 932
 933 =item Arguments: $relname
 934
 935 =item Return value: Hashref of relation data,
 936
 937 =back
 938
 939 Returns a hash of relationship information for the specified relationship
 940 name. The keys/values are as specified for L</add_relationship>.
 941
 942 =cut
 943
 944 sub relationship_info {
 945   my ($self, $rel) = @_;
 946   return $self->_relationships->{$rel};
 947 }
 948
 949 =head2 has_relationship
 950
 951 =over 4
 952
 953 =item Arguments: $rel
 954
 955 =item Return value: 1/0 (true/false)
 956
 957 =back
 958
 959 Returns true if the source has a relationship of this name, false otherwise.
 960
 961 =cut
 962
 963 sub has_relationship {
 964   my ($self, $rel) = @_;
 965   return exists $self->_relationships->{$rel};
 966 }
 967
 968 =head2 reverse_relationship_info
 969
 970 =over 4
 971
 972 =item Arguments: $relname
 973
 974 =item Return value: Hashref of relationship data
 975
 976 =back
 977
 978 Looks through all the relationships on the source this relationship
 979 points to, looking for one whose condition is the reverse of the
 980 condition on this relationship.
 981
 982 A common use of this is to find the name of the C<belongs_to> relation
 983 opposing a C<has_many> relation. For definition of these look in
 984 L<DBIx::Class::Relationship>.
 985
 986 The returned hashref is keyed by the name of the opposing
 987 relationship, and contains its data in the same manner as
 988 L</relationship_info>.
 989
 990 =cut
 991
 992 sub reverse_relationship_info {
 993   my ($self, $rel) = @_;
 994   my $rel_info = $self->relationship_info($rel);
 995   my $ret = {};
 996
 997   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 998
 999   my @cond = keys(%{$rel_info->{cond}});
1000   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1001   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1002
1003   # Get the related result source for this relationship
1004   my $othertable = $self->related_source($rel);
1005
1006   # Get all the relationships for that source that related to this source
1007   # whose foreign column set are our self columns on $rel and whose self
1008   # columns are our foreign columns on $rel.
1009   my @otherrels = $othertable->relationships();
1010   my $otherrelationship;
1011   foreach my $otherrel (@otherrels) {
1012     my $otherrel_info = $othertable->relationship_info($otherrel);
1013
1014     my $back = $othertable->related_source($otherrel);
1015     next unless $back->source_name eq $self->source_name;
1016
1017     my @othertestconds;
1018
1019     if (ref $otherrel_info->{cond} eq 'HASH') {
1020       @othertestconds = ($otherrel_info->{cond});
1021     }
1022     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1023       @othertestconds = @{$otherrel_info->{cond}};
1024     }
1025     else {
1026       next;
1027     }
1028
1029     foreach my $othercond (@othertestconds) {
1030       my @other_cond = keys(%$othercond);
1031       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1032       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1033       next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1034                !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1035       $ret->{$otherrel} =  $otherrel_info;
1036     }
1037   }
1038   return $ret;
1039 }
1040
1041 sub compare_relationship_keys {
1042   carp 'compare_relationship_keys is a private method, stop calling it';
1043   my $self = shift;
1044   $self->_compare_relationship_keys (@_);
1045 }
1046
1047 # Returns true if both sets of keynames are the same, false otherwise.
1048 sub _compare_relationship_keys {
1049   my ($self, $keys1, $keys2) = @_;
1050
1051   # Make sure every keys1 is in keys2
1052   my $found;
1053   foreach my $key (@$keys1) {
1054     $found = 0;
1055     foreach my $prim (@$keys2) {
1056       if ($prim eq $key) {
1057         $found = 1;
1058         last;
1059       }
1060     }
1061     last unless $found;
1062   }
1063
1064   # Make sure every key2 is in key1
1065   if ($found) {
1066     foreach my $prim (@$keys2) {
1067       $found = 0;
1068       foreach my $key (@$keys1) {
1069         if ($prim eq $key) {
1070           $found = 1;
1071           last;
1072         }
1073       }
1074       last unless $found;
1075     }
1076   }
1077
1078   return $found;
1079 }
1080
1081 sub resolve_join {
1082   carp 'resolve_join is a private method, stop calling it';
1083   my $self = shift;
1084   $self->_resolve_join (@_);
1085 }
1086
1087 # Returns the {from} structure used to express JOIN conditions
1088 sub _resolve_join {
1089   my ($self, $join, $alias, $seen, $jpath, $force_left) = @_;
1090
1091   # we need a supplied one, because we do in-place modifications, no returns
1092   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1093     unless ref $seen eq 'HASH';
1094
1095   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1096     unless ref $jpath eq 'ARRAY';
1097
1098   $jpath = [@$jpath];
1099
1100   if (ref $join eq 'ARRAY') {
1101     return
1102       map {
1103         $self->_resolve_join($_, $alias, $seen, $jpath, $force_left);
1104       } @$join;
1105   } elsif (ref $join eq 'HASH') {
1106     return
1107       map {
1108         my $as = ($seen->{$_} ? join ('_', $_, $seen->{$_} + 1) : $_);  # the actual seen value will be incremented below
1109         local $force_left->{force} = $force_left->{force};
1110         (
1111           $self->_resolve_join($_, $alias, $seen, [@$jpath], $force_left),
1112           $self->related_source($_)->_resolve_join(
1113             $join->{$_}, $as, $seen, [@$jpath, $_], $force_left
1114           )
1115         );
1116       } keys %$join;
1117   } elsif (ref $join) {
1118     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1119   } else {
1120
1121     return() unless defined $join;
1122
1123     my $count = ++$seen->{$join};
1124     my $as = ($count > 1 ? "${join}_${count}" : $join);
1125
1126     my $rel_info = $self->relationship_info($join);
1127     $self->throw_exception("No such relationship ${join}") unless $rel_info;
1128     my $type;
1129     if ($force_left) {
1130       $type = 'left';
1131     } else {
1132       $type = $rel_info->{attrs}{join_type} || '';
1133       $force_left = 1 if lc($type) eq 'left';
1134     }
1135
1136     my $rel_src = $self->related_source($join);
1137     return [ { $as => $rel_src->from,
1138                -source_handle => $rel_src->handle,
1139                -join_type => $type,
1140                -join_path => [@$jpath, $join],
1141                -alias => $as,
1142                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1143              },
1144              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1145   }
1146 }
1147
1148 sub pk_depends_on {
1149   carp 'pk_depends_on is a private method, stop calling it';
1150   my $self = shift;
1151   $self->_pk_depends_on (@_);
1152 }
1153
1154 # Determines whether a relation is dependent on an object from this source
1155 # having already been inserted. Takes the name of the relationship and a
1156 # hashref of columns of the related object.
1157 sub _pk_depends_on {
1158   my ($self, $relname, $rel_data) = @_;
1159   my $cond = $self->relationship_info($relname)->{cond};
1160
1161   return 0 unless ref($cond) eq 'HASH';
1162
1163   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1164
1165   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1166
1167   # assume anything that references our PK probably is dependent on us
1168   # rather than vice versa, unless the far side is (a) defined or (b)
1169   # auto-increment
1170
1171   my $rel_source = $self->related_source($relname);
1172
1173   foreach my $p ($self->primary_columns) {
1174     if (exists $keyhash->{$p}) {
1175       unless (defined($rel_data->{$keyhash->{$p}})
1176               || $rel_source->column_info($keyhash->{$p})
1177                             ->{is_auto_increment}) {
1178         return 0;
1179       }
1180     }
1181   }
1182
1183   return 1;
1184 }
1185
1186 sub resolve_condition {
1187   carp 'resolve_condition is a private method, stop calling it';
1188   my $self = shift;
1189   $self->_resolve_condition (@_);
1190 }
1191
1192 # Resolves the passed condition to a concrete query fragment. If given an alias,
1193 # returns a join condition; if given an object, inverts that object to produce
1194 # a related conditional from that object.
1195 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1196
1197 sub _resolve_condition {
1198   my ($self, $cond, $as, $for) = @_;
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 condition $cond 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     my $p = $alias_map;
1345     $p = $p->{$_} for (@$pref_path, $pre);
1346
1347     $self->throw_exception (
1348       "Unable to resolve prefetch $pre - join alias map does not contain an entry for path: "
1349       . join (' -> ', @$pref_path, $pre)
1350     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1351
1352     my $as = shift @{$p->{-join_aliases}};
1353
1354     my $rel_info = $self->relationship_info( $pre );
1355     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1356       unless $rel_info;
1357     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1358     my $rel_source = $self->related_source($pre);
1359
1360     if (exists $rel_info->{attrs}{accessor}
1361          && $rel_info->{attrs}{accessor} eq 'multi') {
1362       $self->throw_exception(
1363         "Can't prefetch has_many ${pre} (join cond too complex)")
1364         unless ref($rel_info->{cond}) eq 'HASH';
1365       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1366       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1367                          keys %{$collapse}) {
1368         my ($last) = ($fail =~ /([^\.]+)$/);
1369         carp (
1370           "Prefetching multiple has_many rels ${last} and ${pre} "
1371           .(length($as_prefix)
1372             ? "at the same level (${as_prefix}) "
1373             : "at top level "
1374           )
1375           . 'will explode the number of row objects retrievable via ->next or ->all. '
1376           . 'Use at your own risk.'
1377         );
1378       }
1379       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1380       #              values %{$rel_info->{cond}};
1381       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1382         # action at a distance. prepending the '.' allows simpler code
1383         # in ResultSet->_collapse_result
1384       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1385                     keys %{$rel_info->{cond}};
1386       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1387                    ? @{$rel_info->{attrs}{order_by}}
1388                    : (defined $rel_info->{attrs}{order_by}
1389                        ? ($rel_info->{attrs}{order_by})
1390                        : ()));
1391       push(@$order, map { "${as}.$_" } (@key, @ord));
1392     }
1393
1394     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1395       $rel_source->columns;
1396   }
1397 }
1398
1399 =head2 related_source
1400
1401 =over 4
1402
1403 =item Arguments: $relname
1404
1405 =item Return value: $source
1406
1407 =back
1408
1409 Returns the result source object for the given relationship.
1410
1411 =cut
1412
1413 sub related_source {
1414   my ($self, $rel) = @_;
1415   if( !$self->has_relationship( $rel ) ) {
1416     $self->throw_exception("No such relationship '$rel'");
1417   }
1418   return $self->schema->source($self->relationship_info($rel)->{source});
1419 }
1420
1421 =head2 related_class
1422
1423 =over 4
1424
1425 =item Arguments: $relname
1426
1427 =item Return value: $classname
1428
1429 =back
1430
1431 Returns the class name for objects in the given relationship.
1432
1433 =cut
1434
1435 sub related_class {
1436   my ($self, $rel) = @_;
1437   if( !$self->has_relationship( $rel ) ) {
1438     $self->throw_exception("No such relationship '$rel'");
1439   }
1440   return $self->schema->class($self->relationship_info($rel)->{source});
1441 }
1442
1443 =head2 handle
1444
1445 Obtain a new handle to this source. Returns an instance of a
1446 L<DBIx::Class::ResultSourceHandle>.
1447
1448 =cut
1449
1450 sub handle {
1451     return new DBIx::Class::ResultSourceHandle({
1452         schema         => $_[0]->schema,
1453         source_moniker => $_[0]->source_name
1454     });
1455 }
1456
1457 =head2 throw_exception
1458
1459 See L<DBIx::Class::Schema/"throw_exception">.
1460
1461 =cut
1462
1463 sub throw_exception {
1464   my $self = shift;
1465   if (defined $self->schema) {
1466     $self->schema->throw_exception(@_);
1467   } else {
1468     croak(@_);
1469   }
1470 }
1471
1472 =head2 source_info
1473
1474 Stores a hashref of per-source metadata.  No specific key names
1475 have yet been standardized, the examples below are purely hypothetical
1476 and don't actually accomplish anything on their own:
1477
1478   __PACKAGE__->source_info({
1479     "_tablespace" => 'fast_disk_array_3',
1480     "_engine" => 'InnoDB',
1481   });
1482
1483 =head2 new
1484
1485   $class->new();
1486
1487   $class->new({attribute_name => value});
1488
1489 Creates a new ResultSource object.  Not normally called directly by end users.
1490
1491 =head2 column_info_from_storage
1492
1493 =over
1494
1495 =item Arguments: 1/0 (default: 0)
1496
1497 =item Return value: 1/0
1498
1499 =back
1500
1501   __PACKAGE__->column_info_from_storage(1);
1502
1503 Enables the on-demand automatic loading of the above column
1504 metadata from storage as neccesary.  This is *deprecated*, and
1505 should not be used.  It will be removed before 1.0.
1506
1507
1508 =head1 AUTHORS
1509
1510 Matt S. Trout <mst@shadowcatsystems.co.uk>
1511
1512 =head1 LICENSE
1513
1514 You may distribute this code under the same terms as Perl itself.
1515
1516 =cut
1517
1518 1;