1 package DBIx::Class::ResultSource;
6 use DBIx::Class::ResultSet;
7 use DBIx::Class::ResultSourceHandle;
8 use Carp::Clan qw/^DBIx::Class/;
11 use base qw/DBIx::Class/;
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/);
18 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
23 DBIx::Class::ResultSource - Result source object
27 # Create a table based result source, in a result class.
29 package MyDB::Schema::Result::Artist;
30 use base qw/DBIx::Class/;
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');
40 # Create a query (view) based result source, in a result class
41 package MyDB::Schema::Result::Year2000CDs;
43 use DBIx::Class::ResultSource::View;
45 __PACKAGE__->load_components('Core');
46 __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
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'"
57 A ResultSource is an object that represents a source of data for querying.
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.
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.
71 Result sources representing select queries, or views, can also be
72 created, see L<DBIx::Class::ResultSource::View> for full details.
74 =head2 Finding result source objects
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>.
79 You can retrieve the result source at runtime in the following ways:
83 =item From a Schema object:
85 $schema->source($source_name);
87 =item From a Row object:
91 =item From a ResultSet object:
104 my ($class, $attrs) = @_;
105 $class = ref $class if ref $class;
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";
125 =item Arguments: @columns
127 =item Return value: The ResultSource object
131 $source->add_columns(qw/col1 col2 col3/);
133 $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
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.
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.
143 The contents of the column_info are not set in stone. The following
144 keys are currently recognised/used by DBIx::Class:
150 { accessor => '_name' }
152 # example use, replace standard accessor with one of your own:
154 my ($self, $value) = @_;
156 die "Name cannot contain digits!" if($value =~ /\d/);
157 $self->_name($value);
159 return $self->_name();
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.
167 { data_type => 'integer' }
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.
173 Currently there is no standard set of values for the data_type. Use
174 whatever your database supports.
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>.
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>.
192 =item is_auto_increment
194 { is_auto_increment => 1 }
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>.
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>
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.
218 { is_foreign_key => 1 }
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>.
226 { default_value => \'now()' }
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>.
234 See the note on L<DBIx::Class::Row/new> for more information about possible
235 issues related to db-side default values.
239 { sequence => 'my_table_seq' }
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
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.
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>.
266 =item Arguments: $colname, \%columninfo?
268 =item Return value: 1/0 (true/false)
272 $source->add_column('col' => \%info);
274 Add a single column and optional column info. Uses the same column
275 info keys as L</add_columns>.
280 my ($self, @cols) = @_;
281 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
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;
292 push @{ $self->_ordered_columns }, @added;
296 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
302 =item Arguments: $colname
304 =item Return value: 1/0 (true/false)
308 if ($source->has_column($colname)) { ... }
310 Returns true if the source has a column of this name, false otherwise.
315 my ($self, $column) = @_;
316 return exists $self->_columns->{$column};
323 =item Arguments: $colname
325 =item Return value: Hashref of info
329 my $info = $source->column_info($col);
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.
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 )
347 $self->{_columns_info_loaded}++;
350 # eval for the case of storage without table
351 eval { $info = $self->storage->columns_info_for( $self->from ) };
353 for my $realcol ( keys %{$info} ) {
354 $lc_info->{lc $realcol} = $info->{$realcol};
356 foreach my $col ( keys %{$self->_columns} ) {
357 $self->_columns->{$col} = {
358 %{ $self->_columns->{$col} },
359 %{ $info->{$col} || $lc_info->{lc $col} || {} }
364 return $self->_columns->{$column};
371 =item Arguments: None
373 =item Return value: Ordered list of column names
377 my @column_names = $source->columns;
379 Returns all column names in the order they were declared to L</add_columns>.
385 $self->throw_exception(
386 "columns() is a read-only accessor, did you mean add_columns()?"
388 return @{$self->{_ordered_columns}||[]};
391 =head2 remove_columns
395 =item Arguments: @colnames
397 =item Return value: undefined
401 $source->remove_columns(qw/col1 col2 col3/);
403 Removes the given list of columns by name, from the result source.
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.
413 =item Arguments: $colname
415 =item Return value: undefined
419 $source->remove_column('col');
421 Remove a single column by name from the result source, similar to
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.
431 my ($self, @to_remove) = @_;
433 my $columns = $self->_columns
438 delete $columns->{$_};
442 $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
445 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
447 =head2 set_primary_key
451 =item Arguments: @cols
453 =item Return value: undefined
457 Defines one or more columns as primary key for this source. Must be
458 called after L</add_columns>.
460 Additionally, defines a L<unique constraint|add_unique_constraint>
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>.
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);
477 $self->_primaries(\@cols);
479 $self->add_unique_constraint(primary => \@cols);
482 =head2 primary_columns
486 =item Arguments: None
488 =item Return value: Ordered list of primary column names
492 Read-only accessor which returns the list of primary keys, supplied by
497 sub primary_columns {
498 return @{shift->_primaries||[]};
501 =head2 add_unique_constraint
505 =item Arguments: $name?, \@colnames
507 =item Return value: undefined
511 Declare a unique constraint on this source. Call once for each unique
514 # For UNIQUE (column1, column2)
515 __PACKAGE__->add_unique_constraint(
516 constraint_name => [ qw/column1 column2/ ],
519 Alternatively, you can specify only the columns:
521 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
523 This will result in a unique constraint named
524 C<table_column1_column2>, where C<table> is replaced with the table
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.
531 Throws an error if any of the given column names do not yet exist on
536 sub add_unique_constraint {
541 $name ||= $self->name_unique_constraint($cols);
543 foreach my $col (@$cols) {
544 $self->throw_exception("No such column $col on table " . $self->name)
545 unless $self->has_column($col);
548 my %unique_constraints = $self->unique_constraints;
549 $unique_constraints{$name} = $cols;
550 $self->_unique_constraints(\%unique_constraints);
553 =head2 name_unique_constraint
557 =item Arguments: @colnames
559 =item Return value: Constraint name
563 $source->table('mytable');
564 $source->name_unique_constraint('col1', 'col2');
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.
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>.
575 This is used by L</add_unique_constraint> if you do not specify the
576 optional constraint name.
580 sub name_unique_constraint {
581 my ($self, $cols) = @_;
583 my $name = $self->name;
584 $name = $$name if ref $name;
586 return join '_', $name, @$cols;
589 =head2 unique_constraints
593 =item Arguments: None
595 =item Return value: Hash of unique constraint data
599 $source->unique_constraints();
601 Read-only accessor which returns a hash of unique constraints on this
604 The hash is keyed by constraint name, and contains an arrayref of
605 column names as values.
609 sub unique_constraints {
610 return %{shift->_unique_constraints||{}};
613 =head2 unique_constraint_names
617 =item Arguments: None
619 =item Return value: Unique constraint names
623 $source->unique_constraint_names();
625 Returns the list of unique constraint names defined on this source.
629 sub unique_constraint_names {
632 my %unique_constraints = $self->unique_constraints;
634 return keys %unique_constraints;
637 =head2 unique_constraint_columns
641 =item Arguments: $constraintname
643 =item Return value: List of constraint columns
647 $source->unique_constraint_columns('myconstraint');
649 Returns the list of columns that make up the specified unique constraint.
653 sub unique_constraint_columns {
654 my ($self, $constraint_name) = @_;
656 my %unique_constraints = $self->unique_constraints;
658 $self->throw_exception(
659 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
660 ) unless exists $unique_constraints{$constraint_name};
662 return @{ $unique_constraints{$constraint_name} };
665 =head2 sqlt_deploy_callback
669 =item Arguments: $callback
673 __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
675 An accessor to set a callback to be called during deployment of
676 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
677 L<DBIx::Class::Schema/deploy>.
679 The callback can be set as either a code reference or the name of a
680 method in the current result class.
682 If not set, the L</default_sqlt_deploy_hook> is called.
684 Your callback will be passed the $source object representing the
685 ResultSource instance being deployed, and the
686 L<SQL::Translator::Schema::Table> object being created from it. The
687 callback can be used to manipulate the table object or add your own
688 customised indexes. If you need to manipulate a non-table object, use
689 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
691 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
692 Your SQL> for examples.
694 This sqlt deployment callback can only be used to manipulate
695 SQL::Translator objects as they get turned into SQL. To execute
696 post-deploy statements which SQL::Translator does not currently
697 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
698 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
700 =head2 default_sqlt_deploy_hook
704 =item Arguments: $source, $sqlt_table
706 =item Return value: undefined
710 This is the sensible default for L</sqlt_deploy_callback>.
712 If a method named C<sqlt_deploy_hook> exists in your Result class, it
713 will be called and passed the current C<$source> and the
714 C<$sqlt_table> being deployed.
718 sub default_sqlt_deploy_hook {
721 my $class = $self->result_class;
723 if ($class and $class->can('sqlt_deploy_hook')) {
724 $class->sqlt_deploy_hook(@_);
728 sub _invoke_sqlt_deploy_hook {
730 if ( my $hook = $self->sqlt_deploy_callback) {
739 =item Arguments: None
741 =item Return value: $resultset
745 Returns a resultset for the given source. This will initially be created
748 $self->resultset_class->new($self, $self->resultset_attributes)
750 but is cached from then on unless resultset_class changes.
752 =head2 resultset_class
756 =item Arguments: $classname
758 =item Return value: $classname
762 package My::Schema::ResultSet::Artist;
763 use base 'DBIx::Class::ResultSet';
766 # In the result class
767 __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
770 $source->resultset_class('My::Schema::ResultSet::Artist');
772 Set the class of the resultset. This is useful if you want to create your
773 own resultset methods. Create your own class derived from
774 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
775 this method returns the name of the existing resultset class, if one
778 =head2 resultset_attributes
782 =item Arguments: \%attrs
784 =item Return value: \%attrs
788 # In the result class
789 __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
792 $source->resultset_attributes({ order_by => [ 'id' ] });
794 Store a collection of resultset attributes, that will be set on every
795 L<DBIx::Class::ResultSet> produced from this result source. For a full
796 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
802 $self->throw_exception(
803 'resultset does not take any arguments. If you want another resultset, '.
804 'call it on the schema instead.'
807 return $self->resultset_class->new(
810 %{$self->{resultset_attributes}},
811 %{$self->schema->default_resultset_attributes}
820 =item Arguments: $source_name
822 =item Result value: $source_name
826 Set an alternate name for the result source when it is loaded into a schema.
827 This is useful if you want to refer to a result source by a name other than
830 package ArchivedBooks;
831 use base qw/DBIx::Class/;
832 __PACKAGE__->table('books_archive');
833 __PACKAGE__->source_name('Books');
835 # from your schema...
836 $schema->resultset('Books')->find(1);
842 =item Arguments: None
844 =item Return value: FROM clause
848 my $from_clause = $source->from();
850 Returns an expression of the source to be supplied to storage to specify
851 retrieval from this source. In the case of a database, the required FROM
858 =item Arguments: None
860 =item Return value: A schema object
864 my $schema = $source->schema();
866 Returns the L<DBIx::Class::Schema> object that this result source
873 =item Arguments: None
875 =item Return value: A Storage object
879 $source->storage->debug(1);
881 Returns the storage handle for the current schema.
883 See also: L<DBIx::Class::Storage>
887 sub storage { shift->schema->storage; }
889 =head2 add_relationship
893 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
895 =item Return value: 1/true if it succeeded
899 $source->add_relationship('relname', 'related_source', $cond, $attrs);
901 L<DBIx::Class::Relationship> describes a series of methods which
902 create pre-defined useful types of relationships. Look there first
903 before using this method directly.
905 The relationship name can be arbitrary, but must be unique for each
906 relationship attached to this result source. 'related_source' should
907 be the name with which the related result source was registered with
908 the current schema. For example:
910 $schema->source('Book')->add_relationship('reviews', 'Review', {
911 'foreign.book_id' => 'self.id',
914 The condition C<$cond> needs to be an L<SQL::Abstract>-style
915 representation of the join between the tables. For example, if you're
916 creating a relation from Author to Book,
918 { 'foreign.author_id' => 'self.id' }
920 will result in the JOIN clause
922 author me JOIN book foreign ON foreign.author_id = me.id
924 You can specify as many foreign => self mappings as necessary.
926 Valid attributes are as follows:
932 Explicitly specifies the type of join to use in the relationship. Any
933 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
934 the SQL command immediately before C<JOIN>.
938 An arrayref containing a list of accessors in the foreign class to proxy in
939 the main class. If, for example, you do the following:
941 CD->might_have(liner_notes => 'LinerNotes', undef, {
942 proxy => [ qw/notes/ ],
945 Then, assuming LinerNotes has an accessor named notes, you can do:
947 my $cd = CD->find(1);
948 # set notes -- LinerNotes object is created if it doesn't exist
949 $cd->notes('Notes go here');
953 Specifies the type of accessor that should be created for the
954 relationship. Valid values are C<single> (for when there is only a single
955 related object), C<multi> (when there can be many), and C<filter> (for
956 when there is a single related object, but you also want the relationship
957 accessor to double as a column accessor). For C<multi> accessors, an
958 add_to_* method is also created, which calls C<create_related> for the
963 Throws an exception if the condition is improperly supplied, or cannot
968 sub add_relationship {
969 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
970 $self->throw_exception("Can't create relationship without join condition")
974 # Check foreign and self are right in cond
975 if ( (ref $cond ||'') eq 'HASH') {
977 $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
978 if /\./ && !/^foreign\./;
982 my %rels = %{ $self->_relationships };
983 $rels{$rel} = { class => $f_source_name,
984 source => $f_source_name,
987 $self->_relationships(\%rels);
991 # XXX disabled. doesn't work properly currently. skip in tests.
993 my $f_source = $self->schema->source($f_source_name);
995 $self->ensure_class_loaded($f_source_name);
996 $f_source = $f_source_name->result_source;
997 #my $s_class = ref($self->schema);
998 #$f_source_name =~ m/^${s_class}::(.*)$/;
999 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
1000 #$f_source = $self->schema->source($f_source_name);
1002 return unless $f_source; # Can't test rel without f_source
1004 eval { $self->_resolve_join($rel, 'me', {}, []) };
1006 if ($@) { # If the resolve failed, back out and re-throw the error
1007 delete $rels{$rel}; #
1008 $self->_relationships(\%rels);
1009 $self->throw_exception("Error creating relationship $rel: $@");
1014 =head2 relationships
1018 =item Arguments: None
1020 =item Return value: List of relationship names
1024 my @relnames = $source->relationships();
1026 Returns all relationship names for this source.
1031 return keys %{shift->_relationships};
1034 =head2 relationship_info
1038 =item Arguments: $relname
1040 =item Return value: Hashref of relation data,
1044 Returns a hash of relationship information for the specified relationship
1045 name. The keys/values are as specified for L</add_relationship>.
1049 sub relationship_info {
1050 my ($self, $rel) = @_;
1051 return $self->_relationships->{$rel};
1054 =head2 has_relationship
1058 =item Arguments: $rel
1060 =item Return value: 1/0 (true/false)
1064 Returns true if the source has a relationship of this name, false otherwise.
1068 sub has_relationship {
1069 my ($self, $rel) = @_;
1070 return exists $self->_relationships->{$rel};
1073 =head2 reverse_relationship_info
1077 =item Arguments: $relname
1079 =item Return value: Hashref of relationship data
1083 Looks through all the relationships on the source this relationship
1084 points to, looking for one whose condition is the reverse of the
1085 condition on this relationship.
1087 A common use of this is to find the name of the C<belongs_to> relation
1088 opposing a C<has_many> relation. For definition of these look in
1089 L<DBIx::Class::Relationship>.
1091 The returned hashref is keyed by the name of the opposing
1092 relationship, and contains its data in the same manner as
1093 L</relationship_info>.
1097 sub reverse_relationship_info {
1098 my ($self, $rel) = @_;
1099 my $rel_info = $self->relationship_info($rel);
1102 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1104 my @cond = keys(%{$rel_info->{cond}});
1105 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1106 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1108 # Get the related result source for this relationship
1109 my $othertable = $self->related_source($rel);
1111 # Get all the relationships for that source that related to this source
1112 # whose foreign column set are our self columns on $rel and whose self
1113 # columns are our foreign columns on $rel.
1114 my @otherrels = $othertable->relationships();
1115 my $otherrelationship;
1116 foreach my $otherrel (@otherrels) {
1117 my $otherrel_info = $othertable->relationship_info($otherrel);
1119 my $back = $othertable->related_source($otherrel);
1120 next unless $back->source_name eq $self->source_name;
1124 if (ref $otherrel_info->{cond} eq 'HASH') {
1125 @othertestconds = ($otherrel_info->{cond});
1127 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1128 @othertestconds = @{$otherrel_info->{cond}};
1134 foreach my $othercond (@othertestconds) {
1135 my @other_cond = keys(%$othercond);
1136 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1137 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1138 next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1139 !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1140 $ret->{$otherrel} = $otherrel_info;
1146 sub compare_relationship_keys {
1147 carp 'compare_relationship_keys is a private method, stop calling it';
1149 $self->_compare_relationship_keys (@_);
1152 # Returns true if both sets of keynames are the same, false otherwise.
1153 sub _compare_relationship_keys {
1154 my ($self, $keys1, $keys2) = @_;
1156 # Make sure every keys1 is in keys2
1158 foreach my $key (@$keys1) {
1160 foreach my $prim (@$keys2) {
1161 if ($prim eq $key) {
1169 # Make sure every key2 is in key1
1171 foreach my $prim (@$keys2) {
1173 foreach my $key (@$keys1) {
1174 if ($prim eq $key) {
1187 carp 'resolve_join is a private method, stop calling it';
1189 $self->_resolve_join (@_);
1192 # Returns the {from} structure used to express JOIN conditions
1194 my ($self, $join, $alias, $seen, $jpath, $force_left) = @_;
1196 # we need a supplied one, because we do in-place modifications, no returns
1197 $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1198 unless ref $seen eq 'HASH';
1200 $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1201 unless ref $jpath eq 'ARRAY';
1205 if (ref $join eq 'ARRAY') {
1208 $self->_resolve_join($_, $alias, $seen, $jpath, $force_left);
1210 } elsif (ref $join eq 'HASH') {
1213 my $as = ($seen->{$_} ? join ('_', $_, $seen->{$_} + 1) : $_); # the actual seen value will be incremented below
1214 local $force_left->{force} = $force_left->{force};
1216 $self->_resolve_join($_, $alias, $seen, [@$jpath], $force_left),
1217 $self->related_source($_)->_resolve_join(
1218 $join->{$_}, $as, $seen, [@$jpath, $_], $force_left
1222 } elsif (ref $join) {
1223 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1226 return() unless defined $join;
1228 my $count = ++$seen->{$join};
1229 my $as = ($count > 1 ? "${join}_${count}" : $join);
1231 my $rel_info = $self->relationship_info($join);
1232 $self->throw_exception("No such relationship ${join}") unless $rel_info;
1237 $type = $rel_info->{attrs}{join_type} || '';
1238 $force_left = 1 if lc($type) eq 'left';
1241 my $rel_src = $self->related_source($join);
1242 return [ { $as => $rel_src->from,
1243 -source_handle => $rel_src->handle,
1244 -join_type => $type,
1245 -join_path => [@$jpath, $join],
1247 -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1249 $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1254 carp 'pk_depends_on is a private method, stop calling it';
1256 $self->_pk_depends_on (@_);
1259 # Determines whether a relation is dependent on an object from this source
1260 # having already been inserted. Takes the name of the relationship and a
1261 # hashref of columns of the related object.
1262 sub _pk_depends_on {
1263 my ($self, $relname, $rel_data) = @_;
1264 my $cond = $self->relationship_info($relname)->{cond};
1266 return 0 unless ref($cond) eq 'HASH';
1268 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1270 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1272 # assume anything that references our PK probably is dependent on us
1273 # rather than vice versa, unless the far side is (a) defined or (b)
1276 my $rel_source = $self->related_source($relname);
1278 foreach my $p ($self->primary_columns) {
1279 if (exists $keyhash->{$p}) {
1280 unless (defined($rel_data->{$keyhash->{$p}})
1281 || $rel_source->column_info($keyhash->{$p})
1282 ->{is_auto_increment}) {
1291 sub resolve_condition {
1292 carp 'resolve_condition is a private method, stop calling it';
1294 $self->_resolve_condition (@_);
1297 # Resolves the passed condition to a concrete query fragment. If given an alias,
1298 # returns a join condition; if given an object, inverts that object to produce
1299 # a related conditional from that object.
1300 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1302 sub _resolve_condition {
1303 my ($self, $cond, $as, $for) = @_;
1304 if (ref $cond eq 'HASH') {
1306 foreach my $k (keys %{$cond}) {
1307 my $v = $cond->{$k};
1308 # XXX should probably check these are valid columns
1309 $k =~ s/^foreign\.// ||
1310 $self->throw_exception("Invalid rel cond key ${k}");
1311 $v =~ s/^self\.// ||
1312 $self->throw_exception("Invalid rel cond val ${v}");
1313 if (ref $for) { # Object
1314 #warn "$self $k $for $v";
1315 unless ($for->has_column_loaded($v)) {
1316 if ($for->in_storage) {
1317 $self->throw_exception(
1318 "Column ${v} not loaded or not passed to new() prior to insert()"
1319 ." on ${for} trying to resolve relationship (maybe you forgot "
1320 ."to call ->discard_changes to get defaults from the db)"
1323 return $UNRESOLVABLE_CONDITION;
1325 $ret{$k} = $for->get_column($v);
1326 #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1328 } elsif (!defined $for) { # undef, i.e. "no object"
1330 } elsif (ref $as eq 'HASH') { # reverse hashref
1331 $ret{$v} = $as->{$k};
1332 } elsif (ref $as) { # reverse object
1333 $ret{$v} = $as->get_column($k);
1334 } elsif (!defined $as) { # undef, i.e. "no reverse object"
1337 $ret{"${as}.${k}"} = "${for}.${v}";
1341 } elsif (ref $cond eq 'ARRAY') {
1342 return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1344 die("Can't handle condition $cond yet :(");
1348 # Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
1349 sub resolve_prefetch {
1350 carp 'resolve_prefetch is a private method, stop calling it';
1352 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1354 if( ref $pre eq 'ARRAY' ) {
1356 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1359 elsif( ref $pre eq 'HASH' ) {
1362 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1363 $self->related_source($_)->resolve_prefetch(
1364 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1369 $self->throw_exception(
1370 "don't know how to resolve prefetch reftype ".ref($pre));
1373 my $count = ++$seen->{$pre};
1374 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1375 my $rel_info = $self->relationship_info( $pre );
1376 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1378 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1379 my $rel_source = $self->related_source($pre);
1381 if (exists $rel_info->{attrs}{accessor}
1382 && $rel_info->{attrs}{accessor} eq 'multi') {
1383 $self->throw_exception(
1384 "Can't prefetch has_many ${pre} (join cond too complex)")
1385 unless ref($rel_info->{cond}) eq 'HASH';
1386 my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1387 if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1388 keys %{$collapse}) {
1389 my ($last) = ($fail =~ /([^\.]+)$/);
1391 "Prefetching multiple has_many rels ${last} and ${pre} "
1392 .(length($as_prefix)
1393 ? "at the same level (${as_prefix}) "
1396 . 'will explode the number of row objects retrievable via ->next or ->all. '
1397 . 'Use at your own risk.'
1400 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1401 # values %{$rel_info->{cond}};
1402 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1403 # action at a distance. prepending the '.' allows simpler code
1404 # in ResultSet->_collapse_result
1405 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1406 keys %{$rel_info->{cond}};
1407 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1408 ? @{$rel_info->{attrs}{order_by}}
1409 : (defined $rel_info->{attrs}{order_by}
1410 ? ($rel_info->{attrs}{order_by})
1412 push(@$order, map { "${as}.$_" } (@key, @ord));
1415 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1416 $rel_source->columns;
1420 # Accepts one or more relationships for the current source and returns an
1421 # array of column names for each of those relationships. Column names are
1422 # prefixed relative to the current source, in accordance with where they appear
1423 # in the supplied relationships. Needs an alias_map generated by
1424 # $rs->_joinpath_aliases
1426 sub _resolve_prefetch {
1427 my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1430 if( ref $pre eq 'ARRAY' ) {
1432 map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1435 elsif( ref $pre eq 'HASH' ) {
1438 $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1439 $self->related_source($_)->_resolve_prefetch(
1440 $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1445 $self->throw_exception(
1446 "don't know how to resolve prefetch reftype ".ref($pre));
1450 $p = $p->{$_} for (@$pref_path, $pre);
1452 $self->throw_exception (
1453 "Unable to resolve prefetch $pre - join alias map does not contain an entry for path: "
1454 . join (' -> ', @$pref_path, $pre)
1455 ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1457 my $as = shift @{$p->{-join_aliases}};
1459 my $rel_info = $self->relationship_info( $pre );
1460 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1462 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1463 my $rel_source = $self->related_source($pre);
1465 if (exists $rel_info->{attrs}{accessor}
1466 && $rel_info->{attrs}{accessor} eq 'multi') {
1467 $self->throw_exception(
1468 "Can't prefetch has_many ${pre} (join cond too complex)")
1469 unless ref($rel_info->{cond}) eq 'HASH';
1470 my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1471 if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1472 keys %{$collapse}) {
1473 my ($last) = ($fail =~ /([^\.]+)$/);
1475 "Prefetching multiple has_many rels ${last} and ${pre} "
1476 .(length($as_prefix)
1477 ? "at the same level (${as_prefix}) "
1480 . 'will explode the number of row objects retrievable via ->next or ->all. '
1481 . 'Use at your own risk.'
1484 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1485 # values %{$rel_info->{cond}};
1486 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1487 # action at a distance. prepending the '.' allows simpler code
1488 # in ResultSet->_collapse_result
1489 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1490 keys %{$rel_info->{cond}};
1491 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1492 ? @{$rel_info->{attrs}{order_by}}
1493 : (defined $rel_info->{attrs}{order_by}
1494 ? ($rel_info->{attrs}{order_by})
1496 push(@$order, map { "${as}.$_" } (@key, @ord));
1499 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1500 $rel_source->columns;
1504 =head2 related_source
1508 =item Arguments: $relname
1510 =item Return value: $source
1514 Returns the result source object for the given relationship.
1518 sub related_source {
1519 my ($self, $rel) = @_;
1520 if( !$self->has_relationship( $rel ) ) {
1521 $self->throw_exception("No such relationship '$rel'");
1523 return $self->schema->source($self->relationship_info($rel)->{source});
1526 =head2 related_class
1530 =item Arguments: $relname
1532 =item Return value: $classname
1536 Returns the class name for objects in the given relationship.
1541 my ($self, $rel) = @_;
1542 if( !$self->has_relationship( $rel ) ) {
1543 $self->throw_exception("No such relationship '$rel'");
1545 return $self->schema->class($self->relationship_info($rel)->{source});
1550 Obtain a new handle to this source. Returns an instance of a
1551 L<DBIx::Class::ResultSourceHandle>.
1556 return new DBIx::Class::ResultSourceHandle({
1557 schema => $_[0]->schema,
1558 source_moniker => $_[0]->source_name
1562 =head2 throw_exception
1564 See L<DBIx::Class::Schema/"throw_exception">.
1568 sub throw_exception {
1570 if (defined $self->schema) {
1571 $self->schema->throw_exception(@_);
1579 Stores a hashref of per-source metadata. No specific key names
1580 have yet been standardized, the examples below are purely hypothetical
1581 and don't actually accomplish anything on their own:
1583 __PACKAGE__->source_info({
1584 "_tablespace" => 'fast_disk_array_3',
1585 "_engine" => 'InnoDB',
1592 $class->new({attribute_name => value});
1594 Creates a new ResultSource object. Not normally called directly by end users.
1596 =head2 column_info_from_storage
1600 =item Arguments: 1/0 (default: 0)
1602 =item Return value: 1/0
1606 __PACKAGE__->column_info_from_storage(1);
1608 Enables the on-demand automatic loading of the above column
1609 metadata from storage as neccesary. This is *deprecated*, and
1610 should not be used. It will be removed before 1.0.
1615 Matt S. Trout <mst@shadowcatsystems.co.uk>
1619 You may distribute this code under the same terms as Perl itself.