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