lib/DBIx/Class/ResultSource.pm

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