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/;
  32
  33   __PACKAGE__->load_components(qw/Core/);
  34   __PACKAGE__->table('artist');
  35   __PACKAGE__->add_columns(qw/ artistid name /);
  36   __PACKAGE__->set_primary_key('artistid');
  37   __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
  38
  39   1;
  40
  41   # Create a query (view) based result source, in a result class
  42   package MyDB::Schema::Result::Year2000CDs;
  43
  44   __PACKAGE__->load_components('Core');
  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> component pulls in the
  64 L<DBIx::Class::ResultSourceProxy::Table> as a base class, which
  65 defines the L<table|DBIx::Class::ResultSourceProxy::Table/table>
  66 method. 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 (@_ > 1);
 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 =head2 add_unique_constraint
 507
 508 =over 4
 509
 510 =item Arguments: $name?, \@colnames
 511
 512 =item Return value: undefined
 513
 514 =back
 515
 516 Declare a unique constraint on this source. Call once for each unique
 517 constraint.
 518
 519   # For UNIQUE (column1, column2)
 520   __PACKAGE__->add_unique_constraint(
 521     constraint_name => [ qw/column1 column2/ ],
 522   );
 523
 524 Alternatively, you can specify only the columns:
 525
 526   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
 527
 528 This will result in a unique constraint named
 529 C<table_column1_column2>, where C<table> is replaced with the table
 530 name.
 531
 532 Unique constraints are used, for example, when you pass the constraint
 533 name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
 534 only columns in the constraint are searched.
 535
 536 Throws an error if any of the given column names do not yet exist on
 537 the result source.
 538
 539 =cut
 540
 541 sub add_unique_constraint {
 542   my $self = shift;
 543   my $cols = pop @_;
 544   my $name = shift;
 545
 546   $name ||= $self->name_unique_constraint($cols);
 547
 548   foreach my $col (@$cols) {
 549     $self->throw_exception("No such column $col on table " . $self->name)
 550       unless $self->has_column($col);
 551   }
 552
 553   my %unique_constraints = $self->unique_constraints;
 554   $unique_constraints{$name} = $cols;
 555   $self->_unique_constraints(\%unique_constraints);
 556 }
 557
 558 =head2 name_unique_constraint
 559
 560 =over 4
 561
 562 =item Arguments: @colnames
 563
 564 =item Return value: Constraint name
 565
 566 =back
 567
 568   $source->table('mytable');
 569   $source->name_unique_constraint('col1', 'col2');
 570   # returns
 571   'mytable_col1_col2'
 572
 573 Return a name for a unique constraint containing the specified
 574 columns. The name is created by joining the table name and each column
 575 name, using an underscore character.
 576
 577 For example, a constraint on a table named C<cd> containing the columns
 578 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 579
 580 This is used by L</add_unique_constraint> if you do not specify the
 581 optional constraint name.
 582
 583 =cut
 584
 585 sub name_unique_constraint {
 586   my ($self, $cols) = @_;
 587
 588   my $name = $self->name;
 589   $name = $$name if (ref $name eq 'SCALAR');
 590
 591   return join '_', $name, @$cols;
 592 }
 593
 594 =head2 unique_constraints
 595
 596 =over 4
 597
 598 =item Arguments: None
 599
 600 =item Return value: Hash of unique constraint data
 601
 602 =back
 603
 604   $source->unique_constraints();
 605
 606 Read-only accessor which returns a hash of unique constraints on this
 607 source.
 608
 609 The hash is keyed by constraint name, and contains an arrayref of
 610 column names as values.
 611
 612 =cut
 613
 614 sub unique_constraints {
 615   return %{shift->_unique_constraints||{}};
 616 }
 617
 618 =head2 unique_constraint_names
 619
 620 =over 4
 621
 622 =item Arguments: None
 623
 624 =item Return value: Unique constraint names
 625
 626 =back
 627
 628   $source->unique_constraint_names();
 629
 630 Returns the list of unique constraint names defined on this source.
 631
 632 =cut
 633
 634 sub unique_constraint_names {
 635   my ($self) = @_;
 636
 637   my %unique_constraints = $self->unique_constraints;
 638
 639   return keys %unique_constraints;
 640 }
 641
 642 =head2 unique_constraint_columns
 643
 644 =over 4
 645
 646 =item Arguments: $constraintname
 647
 648 =item Return value: List of constraint columns
 649
 650 =back
 651
 652   $source->unique_constraint_columns('myconstraint');
 653
 654 Returns the list of columns that make up the specified unique constraint.
 655
 656 =cut
 657
 658 sub unique_constraint_columns {
 659   my ($self, $constraint_name) = @_;
 660
 661   my %unique_constraints = $self->unique_constraints;
 662
 663   $self->throw_exception(
 664     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
 665   ) unless exists $unique_constraints{$constraint_name};
 666
 667   return @{ $unique_constraints{$constraint_name} };
 668 }
 669
 670 =head2 sqlt_deploy_callback
 671
 672 =over
 673
 674 =item Arguments: $callback
 675
 676 =back
 677
 678   __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
 679
 680 An accessor to set a callback to be called during deployment of
 681 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
 682 L<DBIx::Class::Schema/deploy>.
 683
 684 The callback can be set as either a code reference or the name of a
 685 method in the current result class.
 686
 687 If not set, the L</default_sqlt_deploy_hook> is called.
 688
 689 Your callback will be passed the $source object representing the
 690 ResultSource instance being deployed, and the
 691 L<SQL::Translator::Schema::Table> object being created from it. The
 692 callback can be used to manipulate the table object or add your own
 693 customised indexes. If you need to manipulate a non-table object, use
 694 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
 695
 696 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
 697 Your SQL> for examples.
 698
 699 This sqlt deployment callback can only be used to manipulate
 700 SQL::Translator objects as they get turned into SQL. To execute
 701 post-deploy statements which SQL::Translator does not currently
 702 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
 703 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
 704
 705 =head2 default_sqlt_deploy_hook
 706
 707 =over
 708
 709 =item Arguments: $source, $sqlt_table
 710
 711 =item Return value: undefined
 712
 713 =back
 714
 715 This is the sensible default for L</sqlt_deploy_callback>.
 716
 717 If a method named C<sqlt_deploy_hook> exists in your Result class, it
 718 will be called and passed the current C<$source> and the
 719 C<$sqlt_table> being deployed.
 720
 721 =cut
 722
 723 sub default_sqlt_deploy_hook {
 724   my $self = shift;
 725
 726   my $class = $self->result_class;
 727
 728   if ($class and $class->can('sqlt_deploy_hook')) {
 729     $class->sqlt_deploy_hook(@_);
 730   }
 731 }
 732
 733 sub _invoke_sqlt_deploy_hook {
 734   my $self = shift;
 735   if ( my $hook = $self->sqlt_deploy_callback) {
 736     $self->$hook(@_);
 737   }
 738 }
 739
 740 =head2 resultset
 741
 742 =over 4
 743
 744 =item Arguments: None
 745
 746 =item Return value: $resultset
 747
 748 =back
 749
 750 Returns a resultset for the given source. This will initially be created
 751 on demand by calling
 752
 753   $self->resultset_class->new($self, $self->resultset_attributes)
 754
 755 but is cached from then on unless resultset_class changes.
 756
 757 =head2 resultset_class
 758
 759 =over 4
 760
 761 =item Arguments: $classname
 762
 763 =item Return value: $classname
 764
 765 =back
 766
 767   package My::Schema::ResultSet::Artist;
 768   use base 'DBIx::Class::ResultSet';
 769   ...
 770
 771   # In the result class
 772   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
 773
 774   # Or in code
 775   $source->resultset_class('My::Schema::ResultSet::Artist');
 776
 777 Set the class of the resultset. This is useful if you want to create your
 778 own resultset methods. Create your own class derived from
 779 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
 780 this method returns the name of the existing resultset class, if one
 781 exists.
 782
 783 =head2 resultset_attributes
 784
 785 =over 4
 786
 787 =item Arguments: \%attrs
 788
 789 =item Return value: \%attrs
 790
 791 =back
 792
 793   # In the result class
 794   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
 795
 796   # Or in code
 797   $source->resultset_attributes({ order_by => [ 'id' ] });
 798
 799 Store a collection of resultset attributes, that will be set on every
 800 L<DBIx::Class::ResultSet> produced from this result source. For a full
 801 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
 802
 803 =cut
 804
 805 sub resultset {
 806   my $self = shift;
 807   $self->throw_exception(
 808     'resultset does not take any arguments. If you want another resultset, '.
 809     'call it on the schema instead.'
 810   ) if scalar @_;
 811
 812   return $self->resultset_class->new(
 813     $self,
 814     {
 815       %{$self->{resultset_attributes}},
 816       %{$self->schema->default_resultset_attributes}
 817     },
 818   );
 819 }
 820
 821 =head2 source_name
 822
 823 =over 4
 824
 825 =item Arguments: $source_name
 826
 827 =item Result value: $source_name
 828
 829 =back
 830
 831 Set an alternate name for the result source when it is loaded into a schema.
 832 This is useful if you want to refer to a result source by a name other than
 833 its class name.
 834
 835   package ArchivedBooks;
 836   use base qw/DBIx::Class/;
 837   __PACKAGE__->table('books_archive');
 838   __PACKAGE__->source_name('Books');
 839
 840   # from your schema...
 841   $schema->resultset('Books')->find(1);
 842
 843 =head2 from
 844
 845 =over 4
 846
 847 =item Arguments: None
 848
 849 =item Return value: FROM clause
 850
 851 =back
 852
 853   my $from_clause = $source->from();
 854
 855 Returns an expression of the source to be supplied to storage to specify
 856 retrieval from this source. In the case of a database, the required FROM
 857 clause contents.
 858
 859 =head2 schema
 860
 861 =over 4
 862
 863 =item Arguments: None
 864
 865 =item Return value: A schema object
 866
 867 =back
 868
 869   my $schema = $source->schema();
 870
 871 Returns the L<DBIx::Class::Schema> object that this result source
 872 belongs to.
 873
 874 =head2 storage
 875
 876 =over 4
 877
 878 =item Arguments: None
 879
 880 =item Return value: A Storage object
 881
 882 =back
 883
 884   $source->storage->debug(1);
 885
 886 Returns the storage handle for the current schema.
 887
 888 See also: L<DBIx::Class::Storage>
 889
 890 =cut
 891
 892 sub storage { shift->schema->storage; }
 893
 894 =head2 add_relationship
 895
 896 =over 4
 897
 898 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
 899
 900 =item Return value: 1/true if it succeeded
 901
 902 =back
 903
 904   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 905
 906 L<DBIx::Class::Relationship> describes a series of methods which
 907 create pre-defined useful types of relationships. Look there first
 908 before using this method directly.
 909
 910 The relationship name can be arbitrary, but must be unique for each
 911 relationship attached to this result source. 'related_source' should
 912 be the name with which the related result source was registered with
 913 the current schema. For example:
 914
 915   $schema->source('Book')->add_relationship('reviews', 'Review', {
 916     'foreign.book_id' => 'self.id',
 917   });
 918
 919 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 920 representation of the join between the tables. For example, if you're
 921 creating a relation from Author to Book,
 922
 923   { 'foreign.author_id' => 'self.id' }
 924
 925 will result in the JOIN clause
 926
 927   author me JOIN book foreign ON foreign.author_id = me.id
 928
 929 You can specify as many foreign => self mappings as necessary.
 930
 931 Valid attributes are as follows:
 932
 933 =over 4
 934
 935 =item join_type
 936
 937 Explicitly specifies the type of join to use in the relationship. Any
 938 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 939 the SQL command immediately before C<JOIN>.
 940
 941 =item proxy
 942
 943 An arrayref containing a list of accessors in the foreign class to proxy in
 944 the main class. If, for example, you do the following:
 945
 946   CD->might_have(liner_notes => 'LinerNotes', undef, {
 947     proxy => [ qw/notes/ ],
 948   });
 949
 950 Then, assuming LinerNotes has an accessor named notes, you can do:
 951
 952   my $cd = CD->find(1);
 953   # set notes -- LinerNotes object is created if it doesn't exist
 954   $cd->notes('Notes go here');
 955
 956 =item accessor
 957
 958 Specifies the type of accessor that should be created for the
 959 relationship. Valid values are C<single> (for when there is only a single
 960 related object), C<multi> (when there can be many), and C<filter> (for
 961 when there is a single related object, but you also want the relationship
 962 accessor to double as a column accessor). For C<multi> accessors, an
 963 add_to_* method is also created, which calls C<create_related> for the
 964 relationship.
 965
 966 =back
 967
 968 Throws an exception if the condition is improperly supplied, or cannot
 969 be resolved.
 970
 971 =cut
 972
 973 sub add_relationship {
 974   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 975   $self->throw_exception("Can't create relationship without join condition")
 976     unless $cond;
 977   $attrs ||= {};
 978
 979   # Check foreign and self are right in cond
 980   if ( (ref $cond ||'') eq 'HASH') {
 981     for (keys %$cond) {
 982       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
 983         if /\./ && !/^foreign\./;
 984     }
 985   }
 986
 987   my %rels = %{ $self->_relationships };
 988   $rels{$rel} = { class => $f_source_name,
 989                   source => $f_source_name,
 990                   cond  => $cond,
 991                   attrs => $attrs };
 992   $self->_relationships(\%rels);
 993
 994   return $self;
 995
 996   # XXX disabled. doesn't work properly currently. skip in tests.
 997
 998   my $f_source = $self->schema->source($f_source_name);
 999   unless ($f_source) {
1000     $self->ensure_class_loaded($f_source_name);
1001     $f_source = $f_source_name->result_source;
1002     #my $s_class = ref($self->schema);
1003     #$f_source_name =~ m/^${s_class}::(.*)$/;
1004     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
1005     #$f_source = $self->schema->source($f_source_name);
1006   }
1007   return unless $f_source; # Can't test rel without f_source
1008
1009   eval { $self->_resolve_join($rel, 'me', {}, []) };
1010
1011   if ($@) { # If the resolve failed, back out and re-throw the error
1012     delete $rels{$rel}; #
1013     $self->_relationships(\%rels);
1014     $self->throw_exception("Error creating relationship $rel: $@");
1015   }
1016   1;
1017 }
1018
1019 =head2 relationships
1020
1021 =over 4
1022
1023 =item Arguments: None
1024
1025 =item Return value: List of relationship names
1026
1027 =back
1028
1029   my @relnames = $source->relationships();
1030
1031 Returns all relationship names for this source.
1032
1033 =cut
1034
1035 sub relationships {
1036   return keys %{shift->_relationships};
1037 }
1038
1039 =head2 relationship_info
1040
1041 =over 4
1042
1043 =item Arguments: $relname
1044
1045 =item Return value: Hashref of relation data,
1046
1047 =back
1048
1049 Returns a hash of relationship information for the specified relationship
1050 name. The keys/values are as specified for L</add_relationship>.
1051
1052 =cut
1053
1054 sub relationship_info {
1055   my ($self, $rel) = @_;
1056   return $self->_relationships->{$rel};
1057 }
1058
1059 =head2 has_relationship
1060
1061 =over 4
1062
1063 =item Arguments: $rel
1064
1065 =item Return value: 1/0 (true/false)
1066
1067 =back
1068
1069 Returns true if the source has a relationship of this name, false otherwise.
1070
1071 =cut
1072
1073 sub has_relationship {
1074   my ($self, $rel) = @_;
1075   return exists $self->_relationships->{$rel};
1076 }
1077
1078 =head2 reverse_relationship_info
1079
1080 =over 4
1081
1082 =item Arguments: $relname
1083
1084 =item Return value: Hashref of relationship data
1085
1086 =back
1087
1088 Looks through all the relationships on the source this relationship
1089 points to, looking for one whose condition is the reverse of the
1090 condition on this relationship.
1091
1092 A common use of this is to find the name of the C<belongs_to> relation
1093 opposing a C<has_many> relation. For definition of these look in
1094 L<DBIx::Class::Relationship>.
1095
1096 The returned hashref is keyed by the name of the opposing
1097 relationship, and contains its data in the same manner as
1098 L</relationship_info>.
1099
1100 =cut
1101
1102 sub reverse_relationship_info {
1103   my ($self, $rel) = @_;
1104   my $rel_info = $self->relationship_info($rel);
1105   my $ret = {};
1106
1107   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1108
1109   my @cond = keys(%{$rel_info->{cond}});
1110   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1111   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1112
1113   # Get the related result source for this relationship
1114   my $othertable = $self->related_source($rel);
1115
1116   # Get all the relationships for that source that related to this source
1117   # whose foreign column set are our self columns on $rel and whose self
1118   # columns are our foreign columns on $rel.
1119   my @otherrels = $othertable->relationships();
1120   my $otherrelationship;
1121   foreach my $otherrel (@otherrels) {
1122     my $otherrel_info = $othertable->relationship_info($otherrel);
1123
1124     my $back = $othertable->related_source($otherrel);
1125     next unless $back->source_name eq $self->source_name;
1126
1127     my @othertestconds;
1128
1129     if (ref $otherrel_info->{cond} eq 'HASH') {
1130       @othertestconds = ($otherrel_info->{cond});
1131     }
1132     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1133       @othertestconds = @{$otherrel_info->{cond}};
1134     }
1135     else {
1136       next;
1137     }
1138
1139     foreach my $othercond (@othertestconds) {
1140       my @other_cond = keys(%$othercond);
1141       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1142       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1143       next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1144                !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1145       $ret->{$otherrel} =  $otherrel_info;
1146     }
1147   }
1148   return $ret;
1149 }
1150
1151 sub compare_relationship_keys {
1152   carp 'compare_relationship_keys is a private method, stop calling it';
1153   my $self = shift;
1154   $self->_compare_relationship_keys (@_);
1155 }
1156
1157 # Returns true if both sets of keynames are the same, false otherwise.
1158 sub _compare_relationship_keys {
1159   my ($self, $keys1, $keys2) = @_;
1160
1161   # Make sure every keys1 is in keys2
1162   my $found;
1163   foreach my $key (@$keys1) {
1164     $found = 0;
1165     foreach my $prim (@$keys2) {
1166       if ($prim eq $key) {
1167         $found = 1;
1168         last;
1169       }
1170     }
1171     last unless $found;
1172   }
1173
1174   # Make sure every key2 is in key1
1175   if ($found) {
1176     foreach my $prim (@$keys2) {
1177       $found = 0;
1178       foreach my $key (@$keys1) {
1179         if ($prim eq $key) {
1180           $found = 1;
1181           last;
1182         }
1183       }
1184       last unless $found;
1185     }
1186   }
1187
1188   return $found;
1189 }
1190
1191 sub resolve_join {
1192   carp 'resolve_join is a private method, stop calling it';
1193   my $self = shift;
1194   $self->_resolve_join (@_);
1195 }
1196
1197 # Returns the {from} structure used to express JOIN conditions
1198 sub _resolve_join {
1199   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1200
1201   # we need a supplied one, because we do in-place modifications, no returns
1202   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1203     unless ref $seen eq 'HASH';
1204
1205   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1206     unless ref $jpath eq 'ARRAY';
1207
1208   $jpath = [@$jpath];
1209
1210   if (not defined $join) {
1211     return ();
1212   }
1213   elsif (ref $join eq 'ARRAY') {
1214     return
1215       map {
1216         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1217       } @$join;
1218   }
1219   elsif (ref $join eq 'HASH') {
1220
1221     my @ret;
1222     for my $rel (keys %$join) {
1223
1224       my $rel_info = $self->relationship_info($rel)
1225         or $self->throw_exception("No such relationship ${rel}");
1226
1227       my $force_left = $parent_force_left;
1228       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1229
1230       # the actual seen value will be incremented by the recursion
1231       my $as = ($seen->{$rel} ? join ('_', $rel, $seen->{$rel} + 1) : $rel);
1232
1233       push @ret, (
1234         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1235         $self->related_source($rel)->_resolve_join(
1236           $join->{$rel}, $as, $seen, [@$jpath, $rel], $force_left
1237         )
1238       );
1239     }
1240     return @ret;
1241
1242   }
1243   elsif (ref $join) {
1244     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1245   }
1246   else {
1247     my $count = ++$seen->{$join};
1248     my $as = ($count > 1 ? "${join}_${count}" : $join);
1249
1250     my $rel_info = $self->relationship_info($join)
1251       or $self->throw_exception("No such relationship ${join}");
1252
1253     my $rel_src = $self->related_source($join);
1254     return [ { $as => $rel_src->from,
1255                -source_handle => $rel_src->handle,
1256                -join_type => $parent_force_left
1257                   ? 'left'
1258                   : $rel_info->{attrs}{join_type}
1259                 ,
1260                -join_path => [@$jpath, $join],
1261                -alias => $as,
1262                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1263              },
1264              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1265   }
1266 }
1267
1268 sub pk_depends_on {
1269   carp 'pk_depends_on is a private method, stop calling it';
1270   my $self = shift;
1271   $self->_pk_depends_on (@_);
1272 }
1273
1274 # Determines whether a relation is dependent on an object from this source
1275 # having already been inserted. Takes the name of the relationship and a
1276 # hashref of columns of the related object.
1277 sub _pk_depends_on {
1278   my ($self, $relname, $rel_data) = @_;
1279
1280   my $relinfo = $self->relationship_info($relname);
1281
1282   # don't assume things if the relationship direction is specified
1283   return $relinfo->{attrs}{is_foreign_key_constraint}
1284     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1285
1286   my $cond = $relinfo->{cond};
1287   return 0 unless ref($cond) eq 'HASH';
1288
1289   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1290   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1291
1292   # assume anything that references our PK probably is dependent on us
1293   # rather than vice versa, unless the far side is (a) defined or (b)
1294   # auto-increment
1295   my $rel_source = $self->related_source($relname);
1296
1297   foreach my $p ($self->primary_columns) {
1298     if (exists $keyhash->{$p}) {
1299       unless (defined($rel_data->{$keyhash->{$p}})
1300               || $rel_source->column_info($keyhash->{$p})
1301                             ->{is_auto_increment}) {
1302         return 0;
1303       }
1304     }
1305   }
1306
1307   return 1;
1308 }
1309
1310 sub resolve_condition {
1311   carp 'resolve_condition is a private method, stop calling it';
1312   my $self = shift;
1313   $self->_resolve_condition (@_);
1314 }
1315
1316 # Resolves the passed condition to a concrete query fragment. If given an alias,
1317 # returns a join condition; if given an object, inverts that object to produce
1318 # a related conditional from that object.
1319 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1320
1321 sub _resolve_condition {
1322   my ($self, $cond, $as, $for) = @_;
1323   if (ref $cond eq 'HASH') {
1324     my %ret;
1325     foreach my $k (keys %{$cond}) {
1326       my $v = $cond->{$k};
1327       # XXX should probably check these are valid columns
1328       $k =~ s/^foreign\.// ||
1329         $self->throw_exception("Invalid rel cond key ${k}");
1330       $v =~ s/^self\.// ||
1331         $self->throw_exception("Invalid rel cond val ${v}");
1332       if (ref $for) { # Object
1333         #warn "$self $k $for $v";
1334         unless ($for->has_column_loaded($v)) {
1335           if ($for->in_storage) {
1336             $self->throw_exception(sprintf
1337               'Unable to resolve relationship from %s to %s: column %s.%s not '
1338             . 'loaded from storage (or not passed to new() prior to insert()). '
1339             . 'Maybe you forgot to call ->discard_changes to get defaults from the db.',
1340
1341               $for->result_source->source_name,
1342               $as,
1343               $as, $v,
1344             );
1345           }
1346           return $UNRESOLVABLE_CONDITION;
1347         }
1348         $ret{$k} = $for->get_column($v);
1349         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1350         #warn %ret;
1351       } elsif (!defined $for) { # undef, i.e. "no object"
1352         $ret{$k} = undef;
1353       } elsif (ref $as eq 'HASH') { # reverse hashref
1354         $ret{$v} = $as->{$k};
1355       } elsif (ref $as) { # reverse object
1356         $ret{$v} = $as->get_column($k);
1357       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1358         $ret{$v} = undef;
1359       } else {
1360         $ret{"${as}.${k}"} = "${for}.${v}";
1361       }
1362     }
1363     return \%ret;
1364   } elsif (ref $cond eq 'ARRAY') {
1365     return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1366   } else {
1367    die("Can't handle condition $cond yet :(");
1368   }
1369 }
1370
1371 # Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
1372 sub resolve_prefetch {
1373   carp 'resolve_prefetch is a private method, stop calling it';
1374
1375   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1376   $seen ||= {};
1377   if( ref $pre eq 'ARRAY' ) {
1378     return
1379       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1380         @$pre;
1381   }
1382   elsif( ref $pre eq 'HASH' ) {
1383     my @ret =
1384     map {
1385       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1386       $self->related_source($_)->resolve_prefetch(
1387                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1388     } keys %$pre;
1389     return @ret;
1390   }
1391   elsif( ref $pre ) {
1392     $self->throw_exception(
1393       "don't know how to resolve prefetch reftype ".ref($pre));
1394   }
1395   else {
1396     my $count = ++$seen->{$pre};
1397     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1398     my $rel_info = $self->relationship_info( $pre );
1399     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1400       unless $rel_info;
1401     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1402     my $rel_source = $self->related_source($pre);
1403
1404     if (exists $rel_info->{attrs}{accessor}
1405          && $rel_info->{attrs}{accessor} eq 'multi') {
1406       $self->throw_exception(
1407         "Can't prefetch has_many ${pre} (join cond too complex)")
1408         unless ref($rel_info->{cond}) eq 'HASH';
1409       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1410       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1411                          keys %{$collapse}) {
1412         my ($last) = ($fail =~ /([^\.]+)$/);
1413         carp (
1414           "Prefetching multiple has_many rels ${last} and ${pre} "
1415           .(length($as_prefix)
1416             ? "at the same level (${as_prefix}) "
1417             : "at top level "
1418           )
1419           . 'will explode the number of row objects retrievable via ->next or ->all. '
1420           . 'Use at your own risk.'
1421         );
1422       }
1423       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1424       #              values %{$rel_info->{cond}};
1425       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1426         # action at a distance. prepending the '.' allows simpler code
1427         # in ResultSet->_collapse_result
1428       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1429                     keys %{$rel_info->{cond}};
1430       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1431                    ? @{$rel_info->{attrs}{order_by}}
1432                    : (defined $rel_info->{attrs}{order_by}
1433                        ? ($rel_info->{attrs}{order_by})
1434                        : ()));
1435       push(@$order, map { "${as}.$_" } (@key, @ord));
1436     }
1437
1438     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1439       $rel_source->columns;
1440   }
1441 }
1442
1443 # Accepts one or more relationships for the current source and returns an
1444 # array of column names for each of those relationships. Column names are
1445 # prefixed relative to the current source, in accordance with where they appear
1446 # in the supplied relationships. Needs an alias_map generated by
1447 # $rs->_joinpath_aliases
1448
1449 sub _resolve_prefetch {
1450   my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1451   $pref_path ||= [];
1452
1453   if (not defined $pre) {
1454     return ();
1455   }
1456   elsif( ref $pre eq 'ARRAY' ) {
1457     return
1458       map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1459         @$pre;
1460   }
1461   elsif( ref $pre eq 'HASH' ) {
1462     my @ret =
1463     map {
1464       $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1465       $self->related_source($_)->_resolve_prefetch(
1466                $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1467     } keys %$pre;
1468     return @ret;
1469   }
1470   elsif( ref $pre ) {
1471     $self->throw_exception(
1472       "don't know how to resolve prefetch reftype ".ref($pre));
1473   }
1474   else {
1475     my $p = $alias_map;
1476     $p = $p->{$_} for (@$pref_path, $pre);
1477
1478     $self->throw_exception (
1479       "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
1480       . join (' -> ', @$pref_path, $pre)
1481     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1482
1483     my $as = shift @{$p->{-join_aliases}};
1484
1485     my $rel_info = $self->relationship_info( $pre );
1486     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1487       unless $rel_info;
1488     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1489     my $rel_source = $self->related_source($pre);
1490
1491     if (exists $rel_info->{attrs}{accessor}
1492          && $rel_info->{attrs}{accessor} eq 'multi') {
1493       $self->throw_exception(
1494         "Can't prefetch has_many ${pre} (join cond too complex)")
1495         unless ref($rel_info->{cond}) eq 'HASH';
1496       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1497       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1498                          keys %{$collapse}) {
1499         my ($last) = ($fail =~ /([^\.]+)$/);
1500         carp (
1501           "Prefetching multiple has_many rels ${last} and ${pre} "
1502           .(length($as_prefix)
1503             ? "at the same level (${as_prefix}) "
1504             : "at top level "
1505           )
1506           . 'will explode the number of row objects retrievable via ->next or ->all. '
1507           . 'Use at your own risk.'
1508         );
1509       }
1510       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1511       #              values %{$rel_info->{cond}};
1512       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1513         # action at a distance. prepending the '.' allows simpler code
1514         # in ResultSet->_collapse_result
1515       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1516                     keys %{$rel_info->{cond}};
1517       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1518                    ? @{$rel_info->{attrs}{order_by}}
1519                    : (defined $rel_info->{attrs}{order_by}
1520                        ? ($rel_info->{attrs}{order_by})
1521                        : ()));
1522       push(@$order, map { "${as}.$_" } (@key, @ord));
1523     }
1524
1525     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1526       $rel_source->columns;
1527   }
1528 }
1529
1530 =head2 related_source
1531
1532 =over 4
1533
1534 =item Arguments: $relname
1535
1536 =item Return value: $source
1537
1538 =back
1539
1540 Returns the result source object for the given relationship.
1541
1542 =cut
1543
1544 sub related_source {
1545   my ($self, $rel) = @_;
1546   if( !$self->has_relationship( $rel ) ) {
1547     $self->throw_exception("No such relationship '$rel'");
1548   }
1549   return $self->schema->source($self->relationship_info($rel)->{source});
1550 }
1551
1552 =head2 related_class
1553
1554 =over 4
1555
1556 =item Arguments: $relname
1557
1558 =item Return value: $classname
1559
1560 =back
1561
1562 Returns the class name for objects in the given relationship.
1563
1564 =cut
1565
1566 sub related_class {
1567   my ($self, $rel) = @_;
1568   if( !$self->has_relationship( $rel ) ) {
1569     $self->throw_exception("No such relationship '$rel'");
1570   }
1571   return $self->schema->class($self->relationship_info($rel)->{source});
1572 }
1573
1574 =head2 handle
1575
1576 Obtain a new handle to this source. Returns an instance of a
1577 L<DBIx::Class::ResultSourceHandle>.
1578
1579 =cut
1580
1581 sub handle {
1582     return new DBIx::Class::ResultSourceHandle({
1583         schema         => $_[0]->schema,
1584         source_moniker => $_[0]->source_name
1585     });
1586 }
1587
1588 =head2 throw_exception
1589
1590 See L<DBIx::Class::Schema/"throw_exception">.
1591
1592 =cut
1593
1594 sub throw_exception {
1595   my $self = shift;
1596
1597   if (defined $self->schema);
1598     $self->schema->throw_exception(@_);
1599   }
1600   else {
1601     DBIx::Class::Exception->throw(@_);
1602   }
1603 }
1604
1605 =head2 source_info
1606
1607 Stores a hashref of per-source metadata.  No specific key names
1608 have yet been standardized, the examples below are purely hypothetical
1609 and don't actually accomplish anything on their own:
1610
1611   __PACKAGE__->source_info({
1612     "_tablespace" => 'fast_disk_array_3',
1613     "_engine" => 'InnoDB',
1614   });
1615
1616 =head2 new
1617
1618   $class->new();
1619
1620   $class->new({attribute_name => value});
1621
1622 Creates a new ResultSource object.  Not normally called directly by end users.
1623
1624 =head2 column_info_from_storage
1625
1626 =over
1627
1628 =item Arguments: 1/0 (default: 0)
1629
1630 =item Return value: 1/0
1631
1632 =back
1633
1634   __PACKAGE__->column_info_from_storage(1);
1635
1636 Enables the on-demand automatic loading of the above column
1637 metadata from storage as neccesary.  This is *deprecated*, and
1638 should not be used.  It will be removed before 1.0.
1639
1640
1641 =head1 AUTHORS
1642
1643 Matt S. Trout <mst@shadowcatsystems.co.uk>
1644
1645 =head1 LICENSE
1646
1647 You may distribute this code under the same terms as Perl itself.
1648
1649 =cut
1650
1651 1;