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