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