lib/DBIx/Class/ResultSource.pm

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