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 automatically
 249 from a sequence or function (if supported by your Storage driver.) For a
 250 sequence, if you do not use a trigger to get the nextval, you have to set the
 251 L</sequence> value as well.
 252
 253 Also set this for MSSQL columns with the 'uniqueidentifier'
 254 L<DBIx::Class::ResultSource/data_type> whose values you want to automatically
 255 generate using C<NEWID()>, unless they are a primary key in which case this will
 256 be done anyway.
 257
 258 =item extra
 259
 260 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
 261 to add extra non-generic data to the column. For example: C<< extra
 262 => { unsigned => 1} >> is used by the MySQL producer to set an integer
 263 column to unsigned. For more details, see
 264 L<SQL::Translator::Producer::MySQL>.
 265
 266 =back
 267
 268 =head2 add_column
 269
 270 =over
 271
 272 =item Arguments: $colname, \%columninfo?
 273
 274 =item Return value: 1/0 (true/false)
 275
 276 =back
 277
 278   $source->add_column('col' => \%info);
 279
 280 Add a single column and optional column info. Uses the same column
 281 info keys as L</add_columns>.
 282
 283 =cut
 284
 285 sub add_columns {
 286   my ($self, @cols) = @_;
 287   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
 288
 289   my @added;
 290   my $columns = $self->_columns;
 291   while (my $col = shift @cols) {
 292     # If next entry is { ... } use that for the column info, if not
 293     # use an empty hashref
 294     my $column_info = ref $cols[0] ? shift(@cols) : {};
 295     push(@added, $col) unless exists $columns->{$col};
 296     $columns->{$col} = $column_info;
 297   }
 298   push @{ $self->_ordered_columns }, @added;
 299   return $self;
 300 }
 301
 302 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 303
 304 =head2 has_column
 305
 306 =over
 307
 308 =item Arguments: $colname
 309
 310 =item Return value: 1/0 (true/false)
 311
 312 =back
 313
 314   if ($source->has_column($colname)) { ... }
 315
 316 Returns true if the source has a column of this name, false otherwise.
 317
 318 =cut
 319
 320 sub has_column {
 321   my ($self, $column) = @_;
 322   return exists $self->_columns->{$column};
 323 }
 324
 325 =head2 column_info
 326
 327 =over
 328
 329 =item Arguments: $colname
 330
 331 =item Return value: Hashref of info
 332
 333 =back
 334
 335   my $info = $source->column_info($col);
 336
 337 Returns the column metadata hashref for a column, as originally passed
 338 to L</add_columns>. See L</add_columns> above for information on the
 339 contents of the hashref.
 340
 341 =cut
 342
 343 sub column_info {
 344   my ($self, $column) = @_;
 345   $self->throw_exception("No such column $column")
 346     unless exists $self->_columns->{$column};
 347   #warn $self->{_columns_info_loaded}, "\n";
 348   if ( ! $self->_columns->{$column}{data_type}
 349        and $self->column_info_from_storage
 350        and ! $self->{_columns_info_loaded}
 351        and $self->schema and $self->storage )
 352   {
 353     $self->{_columns_info_loaded}++;
 354     my $info = {};
 355     my $lc_info = {};
 356     # eval for the case of storage without table
 357     eval { $info = $self->storage->columns_info_for( $self->from ) };
 358     unless ($@) {
 359       for my $realcol ( keys %{$info} ) {
 360         $lc_info->{lc $realcol} = $info->{$realcol};
 361       }
 362       foreach my $col ( keys %{$self->_columns} ) {
 363         $self->_columns->{$col} = {
 364           %{ $self->_columns->{$col} },
 365           %{ $info->{$col} || $lc_info->{lc $col} || {} }
 366         };
 367       }
 368     }
 369   }
 370   return $self->_columns->{$column};
 371 }
 372
 373 =head2 columns
 374
 375 =over
 376
 377 =item Arguments: None
 378
 379 =item Return value: Ordered list of column names
 380
 381 =back
 382
 383   my @column_names = $source->columns;
 384
 385 Returns all column names in the order they were declared to L</add_columns>.
 386
 387 =cut
 388
 389 sub columns {
 390   my $self = shift;
 391   $self->throw_exception(
 392     "columns() is a read-only accessor, did you mean add_columns()?"
 393   ) if (@_ > 1);
 394   return @{$self->{_ordered_columns}||[]};
 395 }
 396
 397 =head2 remove_columns
 398
 399 =over
 400
 401 =item Arguments: @colnames
 402
 403 =item Return value: undefined
 404
 405 =back
 406
 407   $source->remove_columns(qw/col1 col2 col3/);
 408
 409 Removes the given list of columns by name, from the result source.
 410
 411 B<Warning>: Removing a column that is also used in the sources primary
 412 key, or in one of the sources unique constraints, B<will> result in a
 413 broken result source.
 414
 415 =head2 remove_column
 416
 417 =over
 418
 419 =item Arguments: $colname
 420
 421 =item Return value: undefined
 422
 423 =back
 424
 425   $source->remove_column('col');
 426
 427 Remove a single column by name from the result source, similar to
 428 L</remove_columns>.
 429
 430 B<Warning>: Removing a column that is also used in the sources primary
 431 key, or in one of the sources unique constraints, B<will> result in a
 432 broken result source.
 433
 434 =cut
 435
 436 sub remove_columns {
 437   my ($self, @to_remove) = @_;
 438
 439   my $columns = $self->_columns
 440     or return;
 441
 442   my %to_remove;
 443   for (@to_remove) {
 444     delete $columns->{$_};
 445     ++$to_remove{$_};
 446   }
 447
 448   $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
 449 }
 450
 451 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 452
 453 =head2 set_primary_key
 454
 455 =over 4
 456
 457 =item Arguments: @cols
 458
 459 =item Return value: undefined
 460
 461 =back
 462
 463 Defines one or more columns as primary key for this source. Must be
 464 called after L</add_columns>.
 465
 466 Additionally, defines a L<unique constraint|add_unique_constraint>
 467 named C<primary>.
 468
 469 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 470 retrieve automatically created values from the database. They are also
 471 used as default joining columns when specifying relationships, see
 472 L<DBIx::Class::Relationship>.
 473
 474 =cut
 475
 476 sub set_primary_key {
 477   my ($self, @cols) = @_;
 478   # check if primary key columns are valid columns
 479   foreach my $col (@cols) {
 480     $self->throw_exception("No such column $col on table " . $self->name)
 481       unless $self->has_column($col);
 482   }
 483   $self->_primaries(\@cols);
 484
 485   $self->add_unique_constraint(primary => \@cols);
 486 }
 487
 488 =head2 primary_columns
 489
 490 =over 4
 491
 492 =item Arguments: None
 493
 494 =item Return value: Ordered list of primary column names
 495
 496 =back
 497
 498 Read-only accessor which returns the list of primary keys, supplied by
 499 L</set_primary_key>.
 500
 501 =cut
 502
 503 sub primary_columns {
 504   return @{shift->_primaries||[]};
 505 }
 506
 507 =head2 add_unique_constraint
 508
 509 =over 4
 510
 511 =item Arguments: $name?, \@colnames
 512
 513 =item Return value: undefined
 514
 515 =back
 516
 517 Declare a unique constraint on this source. Call once for each unique
 518 constraint.
 519
 520   # For UNIQUE (column1, column2)
 521   __PACKAGE__->add_unique_constraint(
 522     constraint_name => [ qw/column1 column2/ ],
 523   );
 524
 525 Alternatively, you can specify only the columns:
 526
 527   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
 528
 529 This will result in a unique constraint named
 530 C<table_column1_column2>, where C<table> is replaced with the table
 531 name.
 532
 533 Unique constraints are used, for example, when you pass the constraint
 534 name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
 535 only columns in the constraint are searched.
 536
 537 Throws an error if any of the given column names do not yet exist on
 538 the result source.
 539
 540 =cut
 541
 542 sub add_unique_constraint {
 543   my $self = shift;
 544   my $cols = pop @_;
 545   my $name = shift;
 546
 547   $name ||= $self->name_unique_constraint($cols);
 548
 549   foreach my $col (@$cols) {
 550     $self->throw_exception("No such column $col on table " . $self->name)
 551       unless $self->has_column($col);
 552   }
 553
 554   my %unique_constraints = $self->unique_constraints;
 555   $unique_constraints{$name} = $cols;
 556   $self->_unique_constraints(\%unique_constraints);
 557 }
 558
 559 =head2 name_unique_constraint
 560
 561 =over 4
 562
 563 =item Arguments: @colnames
 564
 565 =item Return value: Constraint name
 566
 567 =back
 568
 569   $source->table('mytable');
 570   $source->name_unique_constraint('col1', 'col2');
 571   # returns
 572   'mytable_col1_col2'
 573
 574 Return a name for a unique constraint containing the specified
 575 columns. The name is created by joining the table name and each column
 576 name, using an underscore character.
 577
 578 For example, a constraint on a table named C<cd> containing the columns
 579 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
 580
 581 This is used by L</add_unique_constraint> if you do not specify the
 582 optional constraint name.
 583
 584 =cut
 585
 586 sub name_unique_constraint {
 587   my ($self, $cols) = @_;
 588
 589   return join '_', $self->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, $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 (ref $join eq 'ARRAY') {
1209     return
1210       map {
1211         $self->_resolve_join($_, $alias, $seen, $jpath, $force_left);
1212       } @$join;
1213   } elsif (ref $join eq 'HASH') {
1214     return
1215       map {
1216         my $as = ($seen->{$_} ? join ('_', $_, $seen->{$_} + 1) : $_);  # the actual seen value will be incremented below
1217         local $force_left->{force} = $force_left->{force};
1218         (
1219           $self->_resolve_join($_, $alias, $seen, [@$jpath], $force_left),
1220           $self->related_source($_)->_resolve_join(
1221             $join->{$_}, $as, $seen, [@$jpath, $_], $force_left
1222           )
1223         );
1224       } keys %$join;
1225   } elsif (ref $join) {
1226     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1227   } else {
1228
1229     return() unless defined $join;
1230
1231     my $count = ++$seen->{$join};
1232     my $as = ($count > 1 ? "${join}_${count}" : $join);
1233
1234     my $rel_info = $self->relationship_info($join);
1235     $self->throw_exception("No such relationship ${join}") unless $rel_info;
1236     my $type;
1237     if ($force_left) {
1238       $type = 'left';
1239     } else {
1240       $type = $rel_info->{attrs}{join_type} || '';
1241       $force_left = 1 if lc($type) eq 'left';
1242     }
1243
1244     my $rel_src = $self->related_source($join);
1245     return [ { $as => $rel_src->from,
1246                -source_handle => $rel_src->handle,
1247                -join_type => $type,
1248                -join_path => [@$jpath, $join],
1249                -alias => $as,
1250                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1251              },
1252              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1253   }
1254 }
1255
1256 sub pk_depends_on {
1257   carp 'pk_depends_on is a private method, stop calling it';
1258   my $self = shift;
1259   $self->_pk_depends_on (@_);
1260 }
1261
1262 # Determines whether a relation is dependent on an object from this source
1263 # having already been inserted. Takes the name of the relationship and a
1264 # hashref of columns of the related object.
1265 sub _pk_depends_on {
1266   my ($self, $relname, $rel_data) = @_;
1267   my $cond = $self->relationship_info($relname)->{cond};
1268
1269   return 0 unless ref($cond) eq 'HASH';
1270
1271   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1272
1273   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1274
1275   # assume anything that references our PK probably is dependent on us
1276   # rather than vice versa, unless the far side is (a) defined or (b)
1277   # auto-increment
1278
1279   my $rel_source = $self->related_source($relname);
1280
1281   foreach my $p ($self->primary_columns) {
1282     if (exists $keyhash->{$p}) {
1283       unless (defined($rel_data->{$keyhash->{$p}})
1284               || $rel_source->column_info($keyhash->{$p})
1285                             ->{is_auto_increment}) {
1286         return 0;
1287       }
1288     }
1289   }
1290
1291   return 1;
1292 }
1293
1294 sub resolve_condition {
1295   carp 'resolve_condition is a private method, stop calling it';
1296   my $self = shift;
1297   $self->_resolve_condition (@_);
1298 }
1299
1300 # Resolves the passed condition to a concrete query fragment. If given an alias,
1301 # returns a join condition; if given an object, inverts that object to produce
1302 # a related conditional from that object.
1303 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1304
1305 sub _resolve_condition {
1306   my ($self, $cond, $as, $for) = @_;
1307   if (ref $cond eq 'HASH') {
1308     my %ret;
1309     foreach my $k (keys %{$cond}) {
1310       my $v = $cond->{$k};
1311       # XXX should probably check these are valid columns
1312       $k =~ s/^foreign\.// ||
1313         $self->throw_exception("Invalid rel cond key ${k}");
1314       $v =~ s/^self\.// ||
1315         $self->throw_exception("Invalid rel cond val ${v}");
1316       if (ref $for) { # Object
1317         #warn "$self $k $for $v";
1318         unless ($for->has_column_loaded($v)) {
1319           if ($for->in_storage) {
1320             $self->throw_exception(
1321               "Column ${v} not loaded or not passed to new() prior to insert()"
1322                 ." on ${for} trying to resolve relationship (maybe you forgot "
1323                   ."to call ->discard_changes to get defaults from the db)"
1324             );
1325           }
1326           return $UNRESOLVABLE_CONDITION;
1327         }
1328         $ret{$k} = $for->get_column($v);
1329         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1330         #warn %ret;
1331       } elsif (!defined $for) { # undef, i.e. "no object"
1332         $ret{$k} = undef;
1333       } elsif (ref $as eq 'HASH') { # reverse hashref
1334         $ret{$v} = $as->{$k};
1335       } elsif (ref $as) { # reverse object
1336         $ret{$v} = $as->get_column($k);
1337       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1338         $ret{$v} = undef;
1339       } else {
1340         $ret{"${as}.${k}"} = "${for}.${v}";
1341       }
1342     }
1343     return \%ret;
1344   } elsif (ref $cond eq 'ARRAY') {
1345     return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1346   } else {
1347    die("Can't handle condition $cond yet :(");
1348   }
1349 }
1350
1351 # Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
1352 sub resolve_prefetch {
1353   carp 'resolve_prefetch is a private method, stop calling it';
1354
1355   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1356   $seen ||= {};
1357   if( ref $pre eq 'ARRAY' ) {
1358     return
1359       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1360         @$pre;
1361   }
1362   elsif( ref $pre eq 'HASH' ) {
1363     my @ret =
1364     map {
1365       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1366       $self->related_source($_)->resolve_prefetch(
1367                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1368     } keys %$pre;
1369     return @ret;
1370   }
1371   elsif( ref $pre ) {
1372     $self->throw_exception(
1373       "don't know how to resolve prefetch reftype ".ref($pre));
1374   }
1375   else {
1376     my $count = ++$seen->{$pre};
1377     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1378     my $rel_info = $self->relationship_info( $pre );
1379     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1380       unless $rel_info;
1381     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1382     my $rel_source = $self->related_source($pre);
1383
1384     if (exists $rel_info->{attrs}{accessor}
1385          && $rel_info->{attrs}{accessor} eq 'multi') {
1386       $self->throw_exception(
1387         "Can't prefetch has_many ${pre} (join cond too complex)")
1388         unless ref($rel_info->{cond}) eq 'HASH';
1389       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1390       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1391                          keys %{$collapse}) {
1392         my ($last) = ($fail =~ /([^\.]+)$/);
1393         carp (
1394           "Prefetching multiple has_many rels ${last} and ${pre} "
1395           .(length($as_prefix)
1396             ? "at the same level (${as_prefix}) "
1397             : "at top level "
1398           )
1399           . 'will explode the number of row objects retrievable via ->next or ->all. '
1400           . 'Use at your own risk.'
1401         );
1402       }
1403       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1404       #              values %{$rel_info->{cond}};
1405       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1406         # action at a distance. prepending the '.' allows simpler code
1407         # in ResultSet->_collapse_result
1408       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1409                     keys %{$rel_info->{cond}};
1410       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1411                    ? @{$rel_info->{attrs}{order_by}}
1412                    : (defined $rel_info->{attrs}{order_by}
1413                        ? ($rel_info->{attrs}{order_by})
1414                        : ()));
1415       push(@$order, map { "${as}.$_" } (@key, @ord));
1416     }
1417
1418     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1419       $rel_source->columns;
1420   }
1421 }
1422
1423 # Accepts one or more relationships for the current source and returns an
1424 # array of column names for each of those relationships. Column names are
1425 # prefixed relative to the current source, in accordance with where they appear
1426 # in the supplied relationships. Needs an alias_map generated by
1427 # $rs->_joinpath_aliases
1428
1429 sub _resolve_prefetch {
1430   my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1431   $pref_path ||= [];
1432
1433   if( ref $pre eq 'ARRAY' ) {
1434     return
1435       map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1436         @$pre;
1437   }
1438   elsif( ref $pre eq 'HASH' ) {
1439     my @ret =
1440     map {
1441       $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1442       $self->related_source($_)->_resolve_prefetch(
1443                $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1444     } keys %$pre;
1445     return @ret;
1446   }
1447   elsif( ref $pre ) {
1448     $self->throw_exception(
1449       "don't know how to resolve prefetch reftype ".ref($pre));
1450   }
1451   else {
1452     my $p = $alias_map;
1453     $p = $p->{$_} for (@$pref_path, $pre);
1454
1455     $self->throw_exception (
1456       "Unable to resolve prefetch $pre - join alias map does not contain an entry for path: "
1457       . join (' -> ', @$pref_path, $pre)
1458     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1459
1460     my $as = shift @{$p->{-join_aliases}};
1461
1462     my $rel_info = $self->relationship_info( $pre );
1463     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1464       unless $rel_info;
1465     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1466     my $rel_source = $self->related_source($pre);
1467
1468     if (exists $rel_info->{attrs}{accessor}
1469          && $rel_info->{attrs}{accessor} eq 'multi') {
1470       $self->throw_exception(
1471         "Can't prefetch has_many ${pre} (join cond too complex)")
1472         unless ref($rel_info->{cond}) eq 'HASH';
1473       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1474       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1475                          keys %{$collapse}) {
1476         my ($last) = ($fail =~ /([^\.]+)$/);
1477         carp (
1478           "Prefetching multiple has_many rels ${last} and ${pre} "
1479           .(length($as_prefix)
1480             ? "at the same level (${as_prefix}) "
1481             : "at top level "
1482           )
1483           . 'will explode the number of row objects retrievable via ->next or ->all. '
1484           . 'Use at your own risk.'
1485         );
1486       }
1487       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1488       #              values %{$rel_info->{cond}};
1489       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1490         # action at a distance. prepending the '.' allows simpler code
1491         # in ResultSet->_collapse_result
1492       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1493                     keys %{$rel_info->{cond}};
1494       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1495                    ? @{$rel_info->{attrs}{order_by}}
1496                    : (defined $rel_info->{attrs}{order_by}
1497                        ? ($rel_info->{attrs}{order_by})
1498                        : ()));
1499       push(@$order, map { "${as}.$_" } (@key, @ord));
1500     }
1501
1502     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1503       $rel_source->columns;
1504   }
1505 }
1506
1507 =head2 related_source
1508
1509 =over 4
1510
1511 =item Arguments: $relname
1512
1513 =item Return value: $source
1514
1515 =back
1516
1517 Returns the result source object for the given relationship.
1518
1519 =cut
1520
1521 sub related_source {
1522   my ($self, $rel) = @_;
1523   if( !$self->has_relationship( $rel ) ) {
1524     $self->throw_exception("No such relationship '$rel'");
1525   }
1526   return $self->schema->source($self->relationship_info($rel)->{source});
1527 }
1528
1529 =head2 related_class
1530
1531 =over 4
1532
1533 =item Arguments: $relname
1534
1535 =item Return value: $classname
1536
1537 =back
1538
1539 Returns the class name for objects in the given relationship.
1540
1541 =cut
1542
1543 sub related_class {
1544   my ($self, $rel) = @_;
1545   if( !$self->has_relationship( $rel ) ) {
1546     $self->throw_exception("No such relationship '$rel'");
1547   }
1548   return $self->schema->class($self->relationship_info($rel)->{source});
1549 }
1550
1551 =head2 handle
1552
1553 Obtain a new handle to this source. Returns an instance of a
1554 L<DBIx::Class::ResultSourceHandle>.
1555
1556 =cut
1557
1558 sub handle {
1559     return new DBIx::Class::ResultSourceHandle({
1560         schema         => $_[0]->schema,
1561         source_moniker => $_[0]->source_name
1562     });
1563 }
1564
1565 =head2 throw_exception
1566
1567 See L<DBIx::Class::Schema/"throw_exception">.
1568
1569 =cut
1570
1571 sub throw_exception {
1572   my $self = shift;
1573   if (defined $self->schema) {
1574     $self->schema->throw_exception(@_);
1575   } else {
1576     croak(@_);
1577   }
1578 }
1579
1580 =head2 source_info
1581
1582 Stores a hashref of per-source metadata.  No specific key names
1583 have yet been standardized, the examples below are purely hypothetical
1584 and don't actually accomplish anything on their own:
1585
1586   __PACKAGE__->source_info({
1587     "_tablespace" => 'fast_disk_array_3',
1588     "_engine" => 'InnoDB',
1589   });
1590
1591 =head2 new
1592
1593   $class->new();
1594
1595   $class->new({attribute_name => value});
1596
1597 Creates a new ResultSource object.  Not normally called directly by end users.
1598
1599 =head2 column_info_from_storage
1600
1601 =over
1602
1603 =item Arguments: 1/0 (default: 0)
1604
1605 =item Return value: 1/0
1606
1607 =back
1608
1609   __PACKAGE__->column_info_from_storage(1);
1610
1611 Enables the on-demand automatic loading of the above column
1612 metadata from storage as neccesary.  This is *deprecated*, and
1613 should not be used.  It will be removed before 1.0.
1614
1615
1616 =head1 AUTHORS
1617
1618 Matt S. Trout <mst@shadowcatsystems.co.uk>
1619
1620 =head1 LICENSE
1621
1622 You may distribute this code under the same terms as Perl itself.
1623
1624 =cut
1625
1626 1;