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