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
29 A ResultSource is a component of a schema from which results can be directly
30 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
32 Basic view support also exists, see L<<DBIx::Class::ResultSource::View>.
41 my ($class, $attrs) = @_;
42 $class = ref $class if ref $class;
44 my $new = bless { %{$attrs || {}} }, $class;
45 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
46 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
47 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
48 $new->{_columns} = { %{$new->{_columns}||{}} };
49 $new->{_relationships} = { %{$new->{_relationships}||{}} };
50 $new->{name} ||= "!!NAME NOT SET!!";
51 $new->{_columns_info_loaded} ||= 0;
52 $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
62 =item Arguments: @columns
64 =item Return value: The ResultSource object
68 $source->add_columns(qw/col1 col2 col3/);
70 $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
72 Adds columns to the result source. If supplied key => hashref pairs, uses
73 the hashref as the column_info for that column. Repeated calls of this
74 method will add more columns, not replace them.
76 The column names given will be created as accessor methods on your
77 L<DBIx::Class::Row> objects. You can change the name of the accessor
78 by supplying an L</accessor> in the column_info hash.
80 The contents of the column_info are not set in stone. The following
81 keys are currently recognised/used by DBIx::Class:
87 Use this to set the name of the accessor method for this column. If unset,
88 the name of the column will be used.
92 This contains the column type. It is automatically filled by the
93 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
94 L<DBIx::Class::Schema::Loader> module. If you do not enter a
95 data_type, DBIx::Class will attempt to retrieve it from the
96 database for you, using L<DBI>'s column_info method. The values of this
97 key are typically upper-cased.
99 Currently there is no standard set of values for the data_type. Use
100 whatever your database supports.
104 The length of your column, if it is a column type that can have a size
105 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
109 Set this to a true value for a columns that is allowed to contain
110 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
112 =item is_auto_increment
114 Set this to a true value for a column whose value is somehow
115 automatically set. This is used to determine which columns to empty
116 when cloning objects using C<copy>. It is also used by
117 L<DBIx::Class::Schema/deploy>.
121 Set this to a true value for a column that contains a key from a
122 foreign table. This is currently only used by
123 L<DBIx::Class::Schema/deploy>.
127 Set this to the default value which will be inserted into a column
128 by the database. Can contain either a value or a function (use a
129 reference to a scalar e.g. C<\'now()'> if you want a function). This
130 is currently only used by L<DBIx::Class::Schema/deploy>.
134 Set this on a primary key column to the name of the sequence used to
135 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
136 will attempt to retrieve the name of the sequence from the database
141 Set this to a true value for a column whose value is retrieved
142 automatically from an oracle sequence. If you do not use an Oracle
143 trigger to get the nextval, you have to set sequence as well.
147 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
148 to add extra non-generic data to the column. For example: C<< extra
149 => { unsigned => 1} >> is used by the MySQL producer to set an integer
150 column to unsigned. For more details, see
151 L<SQL::Translator::Producer::MySQL>.
159 =item Arguments: $colname, [ \%columninfo ]
161 =item Return value: 1/0 (true/false)
165 $source->add_column('col' => \%info?);
167 Add a single column and optional column info. Uses the same column
168 info keys as L</add_columns>.
173 my ($self, @cols) = @_;
174 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
177 my $columns = $self->_columns;
178 while (my $col = shift @cols) {
179 # If next entry is { ... } use that for the column info, if not
180 # use an empty hashref
181 my $column_info = ref $cols[0] ? shift(@cols) : {};
182 push(@added, $col) unless exists $columns->{$col};
183 $columns->{$col} = $column_info;
185 push @{ $self->_ordered_columns }, @added;
189 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
195 =item Arguments: $colname
197 =item Return value: 1/0 (true/false)
201 if ($source->has_column($colname)) { ... }
203 Returns true if the source has a column of this name, false otherwise.
208 my ($self, $column) = @_;
209 return exists $self->_columns->{$column};
216 =item Arguments: $colname
218 =item Return value: Hashref of info
222 my $info = $source->column_info($col);
224 Returns the column metadata hashref for a column, as originally passed
225 to L</add_columns>. See the description of L</add_columns> for information
226 on the contents of the hashref.
231 my ($self, $column) = @_;
232 $self->throw_exception("No such column $column")
233 unless exists $self->_columns->{$column};
234 #warn $self->{_columns_info_loaded}, "\n";
235 if ( ! $self->_columns->{$column}{data_type}
236 and $self->column_info_from_storage
237 and ! $self->{_columns_info_loaded}
238 and $self->schema and $self->storage )
240 $self->{_columns_info_loaded}++;
243 # eval for the case of storage without table
244 eval { $info = $self->storage->columns_info_for( $self->from ) };
246 for my $realcol ( keys %{$info} ) {
247 $lc_info->{lc $realcol} = $info->{$realcol};
249 foreach my $col ( keys %{$self->_columns} ) {
250 $self->_columns->{$col} = {
251 %{ $self->_columns->{$col} },
252 %{ $info->{$col} || $lc_info->{lc $col} || {} }
257 return $self->_columns->{$column};
264 =item Arguments: None
266 =item Return value: Ordered list of column names
270 my @column_names = $source->columns;
272 Returns all column names in the order they were declared to L</add_columns>.
278 $self->throw_exception(
279 "columns() is a read-only accessor, did you mean add_columns()?"
281 return @{$self->{_ordered_columns}||[]};
284 =head2 remove_columns
288 =item Arguments: @colnames
290 =item Return value: undefined
294 $source->remove_columns(qw/col1 col2 col3/);
296 Removes the given list of columns by name, from the result source.
298 B<Warning>: Removing a column that is also used in the sources primary
299 key, or in one of the sources unique constraints, B<will> result in a
300 broken result source.
306 =item Arguments: $colname
308 =item Return value: undefined
312 $source->remove_column('col');
314 Remove a single column by name from the result source, similar to
317 B<Warning>: Removing a column that is also used in the sources primary
318 key, or in one of the sources unique constraints, B<will> result in a
319 broken result source.
324 my ($self, @to_remove) = @_;
326 my $columns = $self->_columns
331 delete $columns->{$_};
335 $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
338 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
340 =head2 set_primary_key
344 =item Arguments: @cols
346 =item Return value: undefined
350 Defines one or more columns as primary key for this source. Should be
351 called after L</add_columns>.
353 Additionally, defines a L<unique constraint|add_unique_constraint>
356 The primary key columns are used by L<DBIx::Class::PK::Auto> to
357 retrieve automatically created values from the database.
361 sub set_primary_key {
362 my ($self, @cols) = @_;
363 # check if primary key columns are valid columns
364 foreach my $col (@cols) {
365 $self->throw_exception("No such column $col on table " . $self->name)
366 unless $self->has_column($col);
368 $self->_primaries(\@cols);
370 $self->add_unique_constraint(primary => \@cols);
373 =head2 primary_columns
377 =item Arguments: None
379 =item Return value: Ordered list of primary column names
383 Read-only accessor which returns the list of primary keys, supplied by
388 sub primary_columns {
389 return @{shift->_primaries||[]};
392 =head2 add_unique_constraint
396 =item Arguments: [ $name ], \@colnames
398 =item Return value: undefined
402 Declare a unique constraint on this source. Call once for each unique
405 # For UNIQUE (column1, column2)
406 __PACKAGE__->add_unique_constraint(
407 constraint_name => [ qw/column1 column2/ ],
410 Alternatively, you can specify only the columns:
412 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
414 This will result in a unique constraint named C<table_column1_column2>, where
415 C<table> is replaced with the table name.
417 Unique constraints are used, for example, when you call
418 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
420 Throws an error if any of the given column names do not yet exist on
425 sub add_unique_constraint {
430 $name ||= $self->name_unique_constraint($cols);
432 foreach my $col (@$cols) {
433 $self->throw_exception("No such column $col on table " . $self->name)
434 unless $self->has_column($col);
437 my %unique_constraints = $self->unique_constraints;
438 $unique_constraints{$name} = $cols;
439 $self->_unique_constraints(\%unique_constraints);
442 =head2 name_unique_constraint
446 =item Arguments: @colnames
448 =item Return value: Constraint name
452 $source->table('mytable');
453 $source->name_unique_constraint('col1', 'col2');
457 Return a name for a unique constraint containing the specified
458 columns. The name is created by joining the table name and each column
459 name, using an underscore character.
461 For example, a constraint on a table named C<cd> containing the columns
462 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
464 This is used by L</add_unique_constraint> if you do not specify the
465 optional constraint name.
469 sub name_unique_constraint {
470 my ($self, $cols) = @_;
472 return join '_', $self->name, @$cols;
475 =head2 unique_constraints
479 =item Arguments: None
481 =item Return value: Hash of unique constraint data
485 $source->unique_constraints();
487 Read-only accessor which returns a hash of unique constraints on this source.
489 The hash is keyed by constraint name, and contains an arrayref of
490 column names as values.
494 sub unique_constraints {
495 return %{shift->_unique_constraints||{}};
498 =head2 unique_constraint_names
502 =item Arguments: None
504 =item Return value: Unique constraint names
508 $source->unique_constraint_names();
510 Returns the list of unique constraint names defined on this source.
514 sub unique_constraint_names {
517 my %unique_constraints = $self->unique_constraints;
519 return keys %unique_constraints;
522 =head2 unique_constraint_columns
526 =item Arguments: $constraintname
528 =item Return value: List of constraint columns
532 $source->unique_constraint_columns('myconstraint');
534 Returns the list of columns that make up the specified unique constraint.
538 sub unique_constraint_columns {
539 my ($self, $constraint_name) = @_;
541 my %unique_constraints = $self->unique_constraints;
543 $self->throw_exception(
544 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
545 ) unless exists $unique_constraints{$constraint_name};
547 return @{ $unique_constraints{$constraint_name} };
550 =head2 sqlt_deploy_callback
554 =item Arguments: $callback
558 __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
560 An accessor to set a callback to be called during deployment of
561 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
562 L<DBIx::Class::Schema/deploy>.
564 The callback can be set as either a code reference or the name of a
565 method in the current result class.
567 If not set, the L</default_sqlt_deploy_hook> is called.
569 Your callback will be passed the $source object representing the
570 ResultSource instance being deployed, and the
571 L<SQL::Translator::Schema::Table> object being created from it. The
572 callback can be used to manipulate the table object or add your own
573 customised indexes. If you need to manipulate a non-table object, use
574 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
576 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
577 Your SQL> for examples.
579 This sqlt deployment callback can only be used to manipulate
580 SQL::Translator objects as they get turned into SQL. To execute
581 post-deploy statements which SQL::Translator does not currently
582 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
583 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
585 =head2 default_sqlt_deploy_hook
589 =item Arguments: $source, $sqlt_table
591 =item Return value: undefined
595 This is the sensible default for L</sqlt_deploy_callback>.
597 If a method named C<sqlt_deploy_hook> exists in your Result class, it
598 will be called and passed the current C<$source> and the
599 C<$sqlt_table> being deployed.
603 sub default_sqlt_deploy_hook {
606 my $class = $self->result_class;
608 if ($class and $class->can('sqlt_deploy_hook')) {
609 $class->sqlt_deploy_hook(@_);
613 sub _invoke_sqlt_deploy_hook {
615 if ( my $hook = $self->sqlt_deploy_callback) {
624 =item Arguments: None
626 =item Return value: $resultset
630 Returns a resultset for the given source. This will initially be created
633 $self->resultset_class->new($self, $self->resultset_attributes)
635 but is cached from then on unless resultset_class changes.
637 =head2 resultset_class
641 =item Arguments: $classname
643 =item Return value: $classname
647 package My::ResultSetClass;
648 use base 'DBIx::Class::ResultSet';
651 $source->resultset_class('My::ResultSet::Class');
653 Set the class of the resultset. This is useful if you want to create your
654 own resultset methods. Create your own class derived from
655 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
656 this method returns the name of the existing resultset class, if one
659 =head2 resultset_attributes
663 =item Arguments: \%attrs
665 =item Return value: \%attrs
669 $source->resultset_attributes({ order_by => [ 'id' ] });
671 Store a collection of resultset attributes, that will be set on every
672 L<DBIx::Class::ResultSet> produced from this result source. For a full
673 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
679 $self->throw_exception(
680 'resultset does not take any arguments. If you want another resultset, '.
681 'call it on the schema instead.'
684 return $self->resultset_class->new(
687 %{$self->{resultset_attributes}},
688 %{$self->schema->default_resultset_attributes}
697 =item Arguments: $source_name
699 =item Result value: $source_name
703 Set an alternate name for the result source when it is loaded into a schema.
704 This is useful if you want to refer to a result source by a name other than
707 package ArchivedBooks;
708 use base qw/DBIx::Class/;
709 __PACKAGE__->table('books_archive');
710 __PACKAGE__->source_name('Books');
712 # from your schema...
713 $schema->resultset('Books')->find(1);
719 =item Arguments: None
721 =item Return value: FROM clause
725 my $from_clause = $source->from();
727 Returns an expression of the source to be supplied to storage to specify
728 retrieval from this source. In the case of a database, the required FROM
735 =item Arguments: None
737 =item Return value: A schema object
741 my $schema = $source->schema();
743 Returns the L<DBIx::Class::Schema> object that this result source
750 =item Arguments: None
752 =item Return value: A Storage object
756 $source->storage->debug(1);
758 Returns the storage handle for the current schema.
760 See also: L<DBIx::Class::Storage>
764 sub storage { shift->schema->storage; }
766 =head2 add_relationship
770 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
772 =item Return value: 1/true if it succeeded
776 $source->add_relationship('relname', 'related_source', $cond, $attrs);
778 L<DBIx::Class::Relationship> describes a series of methods which
779 create pre-defined useful types of relationships. Look there first
780 before using this method directly.
782 The relationship name can be arbitrary, but must be unique for each
783 relationship attached to this result source. 'related_source' should
784 be the name with which the related result source was registered with
785 the current schema. For example:
787 $schema->source('Book')->add_relationship('reviews', 'Review', {
788 'foreign.book_id' => 'self.id',
791 The condition C<$cond> needs to be an L<SQL::Abstract>-style
792 representation of the join between the tables. For example, if you're
793 creating a relation from Author to Book,
795 { 'foreign.author_id' => 'self.id' }
797 will result in the JOIN clause
799 author me JOIN book foreign ON foreign.author_id = me.id
801 You can specify as many foreign => self mappings as necessary.
803 Valid attributes are as follows:
809 Explicitly specifies the type of join to use in the relationship. Any
810 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
811 the SQL command immediately before C<JOIN>.
815 An arrayref containing a list of accessors in the foreign class to proxy in
816 the main class. If, for example, you do the following:
818 CD->might_have(liner_notes => 'LinerNotes', undef, {
819 proxy => [ qw/notes/ ],
822 Then, assuming LinerNotes has an accessor named notes, you can do:
824 my $cd = CD->find(1);
825 # set notes -- LinerNotes object is created if it doesn't exist
826 $cd->notes('Notes go here');
830 Specifies the type of accessor that should be created for the
831 relationship. Valid values are C<single> (for when there is only a single
832 related object), C<multi> (when there can be many), and C<filter> (for
833 when there is a single related object, but you also want the relationship
834 accessor to double as a column accessor). For C<multi> accessors, an
835 add_to_* method is also created, which calls C<create_related> for the
840 Throws an exception if the condition is improperly supplied, or cannot
841 be resolved using L</resolve_join>.
845 sub add_relationship {
846 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
847 $self->throw_exception("Can't create relationship without join condition")
851 # Check foreign and self are right in cond
852 if ( (ref $cond ||'') eq 'HASH') {
854 $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
855 if /\./ && !/^foreign\./;
859 my %rels = %{ $self->_relationships };
860 $rels{$rel} = { class => $f_source_name,
861 source => $f_source_name,
864 $self->_relationships(\%rels);
868 # XXX disabled. doesn't work properly currently. skip in tests.
870 my $f_source = $self->schema->source($f_source_name);
872 $self->ensure_class_loaded($f_source_name);
873 $f_source = $f_source_name->result_source;
874 #my $s_class = ref($self->schema);
875 #$f_source_name =~ m/^${s_class}::(.*)$/;
876 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
877 #$f_source = $self->schema->source($f_source_name);
879 return unless $f_source; # Can't test rel without f_source
881 eval { $self->resolve_join($rel, 'me') };
883 if ($@) { # If the resolve failed, back out and re-throw the error
884 delete $rels{$rel}; #
885 $self->_relationships(\%rels);
886 $self->throw_exception("Error creating relationship $rel: $@");
895 =item Arguments: None
897 =item Return value: List of relationship names
901 my @relnames = $source->relationships();
903 Returns all relationship names for this source.
908 return keys %{shift->_relationships};
911 =head2 relationship_info
915 =item Arguments: $relname
917 =item Return value: Hashref of relation data,
921 Returns a hash of relationship information for the specified relationship
922 name. The keys/values are as specified for L</add_relationship>.
926 sub relationship_info {
927 my ($self, $rel) = @_;
928 return $self->_relationships->{$rel};
931 =head2 has_relationship
935 =item Arguments: $rel
937 =item Return value: 1/0 (true/false)
941 Returns true if the source has a relationship of this name, false otherwise.
945 sub has_relationship {
946 my ($self, $rel) = @_;
947 return exists $self->_relationships->{$rel};
950 =head2 reverse_relationship_info
954 =item Arguments: $relname
956 =item Return value: Hashref of relationship data
960 Looks through all the relationships on the source this relationship
961 points to, looking for one whose condition is the reverse of the
962 condition on this relationship.
964 A common use of this is to find the name of the C<belongs_to> relation
965 opposing a C<has_many> relation. For definition of these look in
966 L<DBIx::Class::Relationship>.
968 The returned hashref is keyed by the name of the opposing
969 relationship, and contains it's data in the same manner as
970 L</relationship_info>.
974 sub reverse_relationship_info {
975 my ($self, $rel) = @_;
976 my $rel_info = $self->relationship_info($rel);
979 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
981 my @cond = keys(%{$rel_info->{cond}});
982 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
983 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
985 # Get the related result source for this relationship
986 my $othertable = $self->related_source($rel);
988 # Get all the relationships for that source that related to this source
989 # whose foreign column set are our self columns on $rel and whose self
990 # columns are our foreign columns on $rel.
991 my @otherrels = $othertable->relationships();
992 my $otherrelationship;
993 foreach my $otherrel (@otherrels) {
994 my $otherrel_info = $othertable->relationship_info($otherrel);
996 my $back = $othertable->related_source($otherrel);
997 next unless $back->source_name eq $self->source_name;
1001 if (ref $otherrel_info->{cond} eq 'HASH') {
1002 @othertestconds = ($otherrel_info->{cond});
1004 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1005 @othertestconds = @{$otherrel_info->{cond}};
1011 foreach my $othercond (@othertestconds) {
1012 my @other_cond = keys(%$othercond);
1013 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1014 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1015 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
1016 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
1017 $ret->{$otherrel} = $otherrel_info;
1023 =head2 compare_relationship_keys
1027 =item Arguments: \@keys1, \@keys2
1029 =item Return value: 1/0 (true/false)
1033 Returns true if both sets of keynames are the same, false otherwise.
1037 sub compare_relationship_keys {
1038 my ($self, $keys1, $keys2) = @_;
1040 # Make sure every keys1 is in keys2
1042 foreach my $key (@$keys1) {
1044 foreach my $prim (@$keys2) {
1045 if ($prim eq $key) {
1053 # Make sure every key2 is in key1
1055 foreach my $prim (@$keys2) {
1057 foreach my $key (@$keys1) {
1058 if ($prim eq $key) {
1074 =item Arguments: $relation
1076 =item Return value: Join condition arrayref
1080 Returns the join structure required for the related result source.
1085 my ($self, $join, $alias, $seen, $force_left) = @_;
1087 $force_left ||= { force => 0 };
1088 if (ref $join eq 'ARRAY') {
1089 return map { $self->resolve_join($_, $alias, $seen) } @$join;
1090 } elsif (ref $join eq 'HASH') {
1093 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
1094 local $force_left->{force};
1096 $self->resolve_join($_, $alias, $seen, $force_left),
1097 $self->related_source($_)->resolve_join(
1098 $join->{$_}, $as, $seen, $force_left
1102 } elsif (ref $join) {
1103 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1105 my $count = ++$seen->{$join};
1106 #use Data::Dumper; warn Dumper($seen);
1107 my $as = ($count > 1 ? "${join}_${count}" : $join);
1108 my $rel_info = $self->relationship_info($join);
1109 $self->throw_exception("No such relationship ${join}") unless $rel_info;
1111 if ($force_left->{force}) {
1114 $type = $rel_info->{attrs}{join_type} || '';
1115 $force_left->{force} = 1 if lc($type) eq 'left';
1117 return [ { $as => $self->related_source($join)->from,
1118 -join_type => $type },
1119 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
1123 =head2 pk_depends_on
1127 =item Arguments: $relname, $rel_data
1129 =item Return value: 1/0 (true/false)
1133 Determines whether a relation is dependent on an object from this source
1134 having already been inserted. Takes the name of the relationship and a
1135 hashref of columns of the related object.
1140 my ($self, $relname, $rel_data) = @_;
1141 my $cond = $self->relationship_info($relname)->{cond};
1143 return 0 unless ref($cond) eq 'HASH';
1145 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1147 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1149 # assume anything that references our PK probably is dependent on us
1150 # rather than vice versa, unless the far side is (a) defined or (b)
1153 my $rel_source = $self->related_source($relname);
1155 foreach my $p ($self->primary_columns) {
1156 if (exists $keyhash->{$p}) {
1157 unless (defined($rel_data->{$keyhash->{$p}})
1158 || $rel_source->column_info($keyhash->{$p})
1159 ->{is_auto_increment}) {
1168 =head2 resolve_condition
1172 =item Arguments: $cond, $as, $alias|$object
1176 Resolves the passed condition to a concrete query fragment. If given an alias,
1177 returns a join condition; if given an object, inverts that object to produce
1178 a related conditional from that object.
1182 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1184 sub resolve_condition {
1185 my ($self, $cond, $as, $for) = @_;
1187 if (ref $cond eq 'HASH') {
1189 foreach my $k (keys %{$cond}) {
1190 my $v = $cond->{$k};
1191 # XXX should probably check these are valid columns
1192 $k =~ s/^foreign\.// ||
1193 $self->throw_exception("Invalid rel cond key ${k}");
1194 $v =~ s/^self\.// ||
1195 $self->throw_exception("Invalid rel cond val ${v}");
1196 if (ref $for) { # Object
1197 #warn "$self $k $for $v";
1198 unless ($for->has_column_loaded($v)) {
1199 if ($for->in_storage) {
1200 $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
1202 return $UNRESOLVABLE_CONDITION;
1204 $ret{$k} = $for->get_column($v);
1205 #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1207 } elsif (!defined $for) { # undef, i.e. "no object"
1209 } elsif (ref $as eq 'HASH') { # reverse hashref
1210 $ret{$v} = $as->{$k};
1211 } elsif (ref $as) { # reverse object
1212 $ret{$v} = $as->get_column($k);
1213 } elsif (!defined $as) { # undef, i.e. "no reverse object"
1216 $ret{"${as}.${k}"} = "${for}.${v}";
1220 } elsif (ref $cond eq 'ARRAY') {
1221 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1223 die("Can't handle this yet :(");
1227 =head2 resolve_prefetch
1231 =item Arguments: hashref/arrayref/scalar
1235 Accepts one or more relationships for the current source and returns an
1236 array of column names for each of those relationships. Column names are
1237 prefixed relative to the current source, in accordance with where they appear
1238 in the supplied relationships. Examples:
1240 my $source = $schema->resultset('Tag')->source;
1241 @columns = $source->resolve_prefetch( { cd => 'artist' } );
1249 # 'cd.artist.artistid',
1253 @columns = $source->resolve_prefetch( qw[/ cd /] );
1263 $source = $schema->resultset('CD')->source;
1264 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1268 # 'artist.artistid',
1270 # 'producer.producerid',
1276 sub resolve_prefetch {
1277 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1279 #$alias ||= $self->name;
1280 #warn $alias, Dumper $pre;
1281 if( ref $pre eq 'ARRAY' ) {
1283 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1286 elsif( ref $pre eq 'HASH' ) {
1289 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1290 $self->related_source($_)->resolve_prefetch(
1291 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1297 $self->throw_exception(
1298 "don't know how to resolve prefetch reftype ".ref($pre));
1301 my $count = ++$seen->{$pre};
1302 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1303 my $rel_info = $self->relationship_info( $pre );
1304 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1306 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1307 my $rel_source = $self->related_source($pre);
1309 if (exists $rel_info->{attrs}{accessor}
1310 && $rel_info->{attrs}{accessor} eq 'multi') {
1311 $self->throw_exception(
1312 "Can't prefetch has_many ${pre} (join cond too complex)")
1313 unless ref($rel_info->{cond}) eq 'HASH';
1314 my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1315 if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1316 keys %{$collapse}) {
1317 my ($last) = ($fail =~ /([^\.]+)$/);
1319 "Prefetching multiple has_many rels ${last} and ${pre} "
1320 .(length($as_prefix)
1321 ? "at the same level (${as_prefix}) "
1324 . 'will currently disrupt both the functionality of $rs->count(), '
1325 . 'and the amount of objects retrievable via $rs->next(). '
1326 . 'Use at your own risk.'
1329 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1330 # values %{$rel_info->{cond}};
1331 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1332 # action at a distance. prepending the '.' allows simpler code
1333 # in ResultSet->_collapse_result
1334 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1335 keys %{$rel_info->{cond}};
1336 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1337 ? @{$rel_info->{attrs}{order_by}}
1338 : (defined $rel_info->{attrs}{order_by}
1339 ? ($rel_info->{attrs}{order_by})
1341 push(@$order, map { "${as}.$_" } (@key, @ord));
1344 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1345 $rel_source->columns;
1346 #warn $alias, Dumper (\@ret);
1351 =head2 related_source
1355 =item Arguments: $relname
1357 =item Return value: $source
1361 Returns the result source object for the given relationship.
1365 sub related_source {
1366 my ($self, $rel) = @_;
1367 if( !$self->has_relationship( $rel ) ) {
1368 $self->throw_exception("No such relationship '$rel'");
1370 return $self->schema->source($self->relationship_info($rel)->{source});
1373 =head2 related_class
1377 =item Arguments: $relname
1379 =item Return value: $classname
1383 Returns the class name for objects in the given relationship.
1388 my ($self, $rel) = @_;
1389 if( !$self->has_relationship( $rel ) ) {
1390 $self->throw_exception("No such relationship '$rel'");
1392 return $self->schema->class($self->relationship_info($rel)->{source});
1397 Obtain a new handle to this source. Returns an instance of a
1398 L<DBIx::Class::ResultSourceHandle>.
1403 return new DBIx::Class::ResultSourceHandle({
1404 schema => $_[0]->schema,
1405 source_moniker => $_[0]->source_name
1409 =head2 throw_exception
1411 See L<DBIx::Class::Schema/"throw_exception">.
1415 sub throw_exception {
1417 if (defined $self->schema) {
1418 $self->schema->throw_exception(@_);
1426 Stores a hashref of per-source metadata. No specific key names
1427 have yet been standardized, the examples below are purely hypothetical
1428 and don't actually accomplish anything on their own:
1430 __PACKAGE__->source_info({
1431 "_tablespace" => 'fast_disk_array_3',
1432 "_engine" => 'InnoDB',
1439 $class->new({attribute_name => value});
1441 Creates a new ResultSource object. Not normally called directly by end users.
1443 =head2 column_info_from_storage
1447 =item Arguments: 1/0 (default: 0)
1449 =item Return value: 1/0
1453 __PACKAGE__->column_info_from_storage(1);
1455 Enables the on-demand automatic loading of the above column
1456 metadata from storage as neccesary. This is *deprecated*, and
1457 should not be used. It will be removed before 1.0.
1462 Matt S. Trout <mst@shadowcatsystems.co.uk>
1466 You may distribute this code under the same terms as Perl itself.