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>)
39 my ($class, $attrs) = @_;
40 $class = ref $class if ref $class;
42 my $new = bless { %{$attrs || {}} }, $class;
43 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
44 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
45 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
46 $new->{_columns} = { %{$new->{_columns}||{}} };
47 $new->{_relationships} = { %{$new->{_relationships}||{}} };
48 $new->{name} ||= "!!NAME NOT SET!!";
49 $new->{_columns_info_loaded} ||= 0;
50 $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
60 =item Arguments: @columns
62 =item Return value: The ResultSource object
66 $source->add_columns(qw/col1 col2 col3/);
68 $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
70 Adds columns to the result source. If supplied key => hashref pairs, uses
71 the hashref as the column_info for that column. Repeated calls of this
72 method will add more columns, not replace them.
74 The column names given will be created as accessor methods on your
75 L<DBIx::Class::Row> objects, you can change the name of the accessor
76 by supplying an L</accessor> in the column_info hash.
78 The contents of the column_info are not set in stone. The following
79 keys are currently recognised/used by DBIx::Class:
85 Use this to set the name of the accessor method for this column. If unset,
86 the name of the column will be used.
90 This contains the column type. It is automatically filled by the
91 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
92 L<DBIx::Class::Schema::Loader> module. If you do not enter a
93 data_type, DBIx::Class will attempt to retrieve it from the
94 database for you, using L<DBI>'s column_info method. The values of this
95 key are typically upper-cased.
97 Currently there is no standard set of values for the data_type. Use
98 whatever your database supports.
102 The length of your column, if it is a column type that can have a size
103 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
107 Set this to a true value for a columns that is allowed to contain
108 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
110 =item is_auto_increment
112 Set this to a true value for a column whose value is somehow
113 automatically set. This is used to determine which columns to empty
114 when cloning objects using C<copy>. It is also used by
115 L<DBIx::Class::Schema/deploy>.
119 Set this to a true value for a column that contains a key from a
120 foreign table. This is currently only used by
121 L<DBIx::Class::Schema/deploy>.
125 Set this to the default value which will be inserted into a column
126 by the database. Can contain either a value or a function. This is
127 currently only used by L<DBIx::Class::Schema/deploy>.
131 Set this on a primary key column to the name of the sequence used to
132 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
133 will attempt to retrieve the name of the sequence from the database
138 Set this to a true value for a column whose value is retrieved
139 automatically from an oracle sequence. If you do not use an oracle
140 trigger to get the nextval, you have to set sequence as well.
144 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
145 to add extra non-generic data to the column. For example: C<< extra
146 => { unsigned => 1} >> is used by the MySQL producer to set an integer
147 column to unsigned. For more details, see
148 L<SQL::Translator::Producer::MySQL>.
156 =item Arguments: $colname, [ \%columninfo ]
158 =item Return value: 1/0 (true/false)
162 $source->add_column('col' => \%info?);
164 Add a single column and optional column info. Uses the same column
165 info keys as L</add_columns>.
170 my ($self, @cols) = @_;
171 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
174 my $columns = $self->_columns;
175 while (my $col = shift @cols) {
176 # If next entry is { ... } use that for the column info, if not
177 # use an empty hashref
178 my $column_info = ref $cols[0] ? shift(@cols) : {};
179 push(@added, $col) unless exists $columns->{$col};
180 $columns->{$col} = $column_info;
182 push @{ $self->_ordered_columns }, @added;
186 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
192 =item Arguments: $colname
194 =item Return value: 1/0 (true/false)
198 if ($source->has_column($colname)) { ... }
200 Returns true if the source has a column of this name, false otherwise.
205 my ($self, $column) = @_;
206 return exists $self->_columns->{$column};
213 =item Arguments: $colname
215 =item Return value: Hashref of info
219 my $info = $source->column_info($col);
221 Returns the column metadata hashref for a column, as originally passed
222 to L</add_columns>. See the description of L</add_columns> for information
223 on the contents of the hashref.
228 my ($self, $column) = @_;
229 $self->throw_exception("No such column $column")
230 unless exists $self->_columns->{$column};
231 #warn $self->{_columns_info_loaded}, "\n";
232 if ( ! $self->_columns->{$column}{data_type}
233 and $self->column_info_from_storage
234 and ! $self->{_columns_info_loaded}
235 and $self->schema and $self->storage )
237 $self->{_columns_info_loaded}++;
240 # eval for the case of storage without table
241 eval { $info = $self->storage->columns_info_for( $self->from ) };
243 for my $realcol ( keys %{$info} ) {
244 $lc_info->{lc $realcol} = $info->{$realcol};
246 foreach my $col ( keys %{$self->_columns} ) {
247 $self->_columns->{$col} = {
248 %{ $self->_columns->{$col} },
249 %{ $info->{$col} || $lc_info->{lc $col} || {} }
254 return $self->_columns->{$column};
261 =item Arguments: None
263 =item Return value: Ordered list of column names
267 my @column_names = $source->columns;
269 Returns all column names in the order they were declared to L</add_columns>.
275 $self->throw_exception(
276 "columns() is a read-only accessor, did you mean add_columns()?"
278 return @{$self->{_ordered_columns}||[]};
281 =head2 remove_columns
285 =item Arguments: @colnames
287 =item Return value: undefined
291 $source->remove_columns(qw/col1 col2 col3/);
293 Removes the given list of columns by name, from the result source.
295 B<Warning>: Removing a column that is also used in the sources primary
296 key, or in one of the sources unique constraints, B<will> result in a
297 broken result source.
303 =item Arguments: $colname
305 =item Return value: undefined
309 $source->remove_column('col');
311 Remove a single column by name from the result source, similar to
314 B<Warning>: Removing a column that is also used in the sources primary
315 key, or in one of the sources unique constraints, B<will> result in a
316 broken result source.
321 my ($self, @to_remove) = @_;
323 my $columns = $self->_columns
328 delete $columns->{$_};
332 $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
335 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
337 =head2 set_primary_key
341 =item Arguments: @cols
343 =item Return value: undefined
347 Defines one or more columns as primary key for this source. Should be
348 called after L</add_columns>.
350 Additionally, defines a L<unique constraint|add_unique_constraint>
353 The primary key columns are used by L<DBIx::Class::PK::Auto> to
354 retrieve automatically created values from the database.
358 sub set_primary_key {
359 my ($self, @cols) = @_;
360 # check if primary key columns are valid columns
361 foreach my $col (@cols) {
362 $self->throw_exception("No such column $col on table " . $self->name)
363 unless $self->has_column($col);
365 $self->_primaries(\@cols);
367 $self->add_unique_constraint(primary => \@cols);
370 =head2 primary_columns
374 =item Arguments: None
376 =item Return value: Ordered list of primary column names
380 Read-only accessor which returns the list of primary keys, supplied by
385 sub primary_columns {
386 return @{shift->_primaries||[]};
389 =head2 add_unique_constraint
393 =item Arguments: [ $name ], \@colnames
395 =item Return value: undefined
399 Declare a unique constraint on this source. Call once for each unique
402 # For UNIQUE (column1, column2)
403 __PACKAGE__->add_unique_constraint(
404 constraint_name => [ qw/column1 column2/ ],
407 Alternatively, you can specify only the columns:
409 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
411 This will result in a unique constraint named C<table_column1_column2>, where
412 C<table> is replaced with the table name.
414 Unique constraints are used, for example, when you call
415 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
417 Throws an error if any of the given column names do not yet exist on
422 sub add_unique_constraint {
427 $name ||= $self->name_unique_constraint($cols);
429 foreach my $col (@$cols) {
430 $self->throw_exception("No such column $col on table " . $self->name)
431 unless $self->has_column($col);
434 my %unique_constraints = $self->unique_constraints;
435 $unique_constraints{$name} = $cols;
436 $self->_unique_constraints(\%unique_constraints);
439 =head2 name_unique_constraint
443 =item Arguments: @colnames
445 =item Return value: Constraint name
449 $source->table('mytable');
450 $source->name_unique_constraint('col1', 'col2');
454 Return a name for a unique constraint containing the specified
455 columns. The name is created by joining the table name and each column
456 name, using an underscore character.
458 For example, a constraint on a table named C<cd> containing the columns
459 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
461 This is used by L</add_unique_constraint> if you do not specify the
462 optional constraint name.
466 sub name_unique_constraint {
467 my ($self, $cols) = @_;
469 return join '_', $self->name, @$cols;
472 =head2 unique_constraints
476 =item Arguments: None
478 =item Return value: Hash of unique constraint data
482 $source->unique_constraints();
484 Read-only accessor which returns a hash of unique constraints on this source.
486 The hash is keyed by constraint name, and contains an arrayref of
487 column names as values.
491 sub unique_constraints {
492 return %{shift->_unique_constraints||{}};
495 =head2 unique_constraint_names
499 =item Arguments: None
501 =item Return value: Unique constraint names
505 $source->unique_constraint_names();
507 Returns the list of unique constraint names defined on this source.
511 sub unique_constraint_names {
514 my %unique_constraints = $self->unique_constraints;
516 return keys %unique_constraints;
519 =head2 unique_constraint_columns
523 =item Arguments: $constraintname
525 =item Return value: List of constraint columns
529 $source->unique_constraint_columns('myconstraint');
531 Returns the list of columns that make up the specified unique constraint.
535 sub unique_constraint_columns {
536 my ($self, $constraint_name) = @_;
538 my %unique_constraints = $self->unique_constraints;
540 $self->throw_exception(
541 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
542 ) unless exists $unique_constraints{$constraint_name};
544 return @{ $unique_constraints{$constraint_name} };
551 =item Arguments: None
553 =item Return value: $resultset
557 Returns a resultset for the given source. This will initially be created
560 $self->resultset_class->new($self, $self->resultset_attributes)
562 but is cached from then on unless resultset_class changes.
564 =head2 resultset_class
568 =item Arguments: $classname
570 =item Return value: $classname
574 package My::ResultSetClass;
575 use base 'DBIx::Class::ResultSet';
578 $source->resultset_class('My::ResultSet::Class');
580 Set the class of the resultset, this is useful if you want to create your
581 own resultset methods. Create your own class derived from
582 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
583 this method returns the name of the existing resultset class, if one
586 =head2 resultset_attributes
590 =item Arguments: \%attrs
592 =item Return value: \%attrs
596 $source->resultset_attributes({ order_by => [ 'id' ] });
598 Store a collection of resultset attributes, that will be set on every
599 L<DBIx::Class::ResultSet> produced from this result source. For a full
600 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
606 $self->throw_exception(
607 'resultset does not take any arguments. If you want another resultset, '.
608 'call it on the schema instead.'
611 return $self->resultset_class->new(
614 %{$self->{resultset_attributes}},
615 %{$self->schema->default_resultset_attributes}
624 =item Arguments: $source_name
626 =item Result value: $source_name
630 Set an alternate name for the result source when it is loaded into a schema.
631 This is useful if you want to refer to a result source by a name other than
634 package ArchivedBooks;
635 use base qw/DBIx::Class/;
636 __PACKAGE__->table('books_archive');
637 __PACKAGE__->source_name('Books');
639 # from your schema...
640 $schema->resultset('Books')->find(1);
646 =item Arguments: None
648 =item Return value: FROM clause
652 my $from_clause = $source->from();
654 Returns an expression of the source to be supplied to storage to specify
655 retrieval from this source. In the case of a database, the required FROM
662 =item Arguments: None
664 =item Return value: A schema object
668 my $schema = $source->schema();
670 Returns the L<DBIx::Class::Schema> object that this result source
677 =item Arguments: None
679 =item Return value: A Storage object
683 $source->storage->debug(1);
685 Returns the storage handle for the current schema.
687 See also: L<DBIx::Class::Storage>
691 sub storage { shift->schema->storage; }
693 =head2 add_relationship
697 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
699 =item Return value: 1/true if it succeeded
703 $source->add_relationship('relname', 'related_source', $cond, $attrs);
705 L<DBIx::Class::Relationship> describes a series of methods which
706 create pre-defined useful types of relationships. Look there first
707 before using this method directly.
709 The relationship name can be arbitrary, but must be unique for each
710 relationship attached to this result source. 'related_source' should
711 be the name with which the related result source was registered with
712 the current schema. For example:
714 $schema->source('Book')->add_relationship('reviews', 'Review', {
715 'foreign.book_id' => 'self.id',
718 The condition C<$cond> needs to be an L<SQL::Abstract>-style
719 representation of the join between the tables. For example, if you're
720 creating a relation from Author to Book,
722 { 'foreign.author_id' => 'self.id' }
724 will result in the JOIN clause
726 author me JOIN book foreign ON foreign.author_id = me.id
728 You can specify as many foreign => self mappings as necessary.
730 Valid attributes are as follows:
736 Explicitly specifies the type of join to use in the relationship. Any
737 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
738 the SQL command immediately before C<JOIN>.
742 An arrayref containing a list of accessors in the foreign class to proxy in
743 the main class. If, for example, you do the following:
745 CD->might_have(liner_notes => 'LinerNotes', undef, {
746 proxy => [ qw/notes/ ],
749 Then, assuming LinerNotes has an accessor named notes, you can do:
751 my $cd = CD->find(1);
752 # set notes -- LinerNotes object is created if it doesn't exist
753 $cd->notes('Notes go here');
757 Specifies the type of accessor that should be created for the
758 relationship. Valid values are C<single> (for when there is only a single
759 related object), C<multi> (when there can be many), and C<filter> (for
760 when there is a single related object, but you also want the relationship
761 accessor to double as a column accessor). For C<multi> accessors, an
762 add_to_* method is also created, which calls C<create_related> for the
767 Throws an exception if the condition is improperly supplied, or cannot
768 be resolved using L</resolve_join>.
772 sub add_relationship {
773 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
774 $self->throw_exception("Can't create relationship without join condition")
778 # Check foreign and self are right in cond
779 if ( (ref $cond ||'') eq 'HASH') {
781 $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
782 if /\./ && !/^foreign\./;
786 my %rels = %{ $self->_relationships };
787 $rels{$rel} = { class => $f_source_name,
788 source => $f_source_name,
791 $self->_relationships(\%rels);
795 # XXX disabled. doesn't work properly currently. skip in tests.
797 my $f_source = $self->schema->source($f_source_name);
799 $self->ensure_class_loaded($f_source_name);
800 $f_source = $f_source_name->result_source;
801 #my $s_class = ref($self->schema);
802 #$f_source_name =~ m/^${s_class}::(.*)$/;
803 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
804 #$f_source = $self->schema->source($f_source_name);
806 return unless $f_source; # Can't test rel without f_source
808 eval { $self->resolve_join($rel, 'me') };
810 if ($@) { # If the resolve failed, back out and re-throw the error
811 delete $rels{$rel}; #
812 $self->_relationships(\%rels);
813 $self->throw_exception("Error creating relationship $rel: $@");
822 =item Arguments: None
824 =item Return value: List of relationship names
828 my @relnames = $source->relationships();
830 Returns all relationship names for this source.
835 return keys %{shift->_relationships};
838 =head2 relationship_info
842 =item Arguments: $relname
844 =item Return value: Hashref of relation data,
848 Returns a hash of relationship information for the specified relationship
849 name. The keys/values are as specified for L</add_relationship>.
853 sub relationship_info {
854 my ($self, $rel) = @_;
855 return $self->_relationships->{$rel};
858 =head2 has_relationship
862 =item Arguments: $rel
864 =item Return value: 1/0 (true/false)
868 Returns true if the source has a relationship of this name, false otherwise.
872 sub has_relationship {
873 my ($self, $rel) = @_;
874 return exists $self->_relationships->{$rel};
877 =head2 reverse_relationship_info
881 =item Arguments: $relname
883 =item Return value: Hashref of relationship data
887 Looks through all the relationships on the source this relationship
888 points to, looking for one whose condition is the reverse of the
889 condition on this relationship.
891 A common use of this is to find the name of the C<belongs_to> relation
892 opposing a C<has_many> relation. For definition of these look in
893 L<DBIx::Class::Relationship>.
895 The returned hashref is keyed by the name of the opposing
896 relationship, and contains it's data in the same manner as
897 L</relationship_info>.
901 sub reverse_relationship_info {
902 my ($self, $rel) = @_;
903 my $rel_info = $self->relationship_info($rel);
906 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
908 my @cond = keys(%{$rel_info->{cond}});
909 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
910 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
912 # Get the related result source for this relationship
913 my $othertable = $self->related_source($rel);
915 # Get all the relationships for that source that related to this source
916 # whose foreign column set are our self columns on $rel and whose self
917 # columns are our foreign columns on $rel.
918 my @otherrels = $othertable->relationships();
919 my $otherrelationship;
920 foreach my $otherrel (@otherrels) {
921 my $otherrel_info = $othertable->relationship_info($otherrel);
923 my $back = $othertable->related_source($otherrel);
924 next unless $back->source_name eq $self->source_name;
928 if (ref $otherrel_info->{cond} eq 'HASH') {
929 @othertestconds = ($otherrel_info->{cond});
931 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
932 @othertestconds = @{$otherrel_info->{cond}};
938 foreach my $othercond (@othertestconds) {
939 my @other_cond = keys(%$othercond);
940 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
941 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
942 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
943 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
944 $ret->{$otherrel} = $otherrel_info;
950 =head2 compare_relationship_keys
954 =item Arguments: \@keys1, \@keys2
956 =item Return value: 1/0 (true/false)
960 Returns true if both sets of keynames are the same, false otherwise.
964 sub compare_relationship_keys {
965 my ($self, $keys1, $keys2) = @_;
967 # Make sure every keys1 is in keys2
969 foreach my $key (@$keys1) {
971 foreach my $prim (@$keys2) {
980 # Make sure every key2 is in key1
982 foreach my $prim (@$keys2) {
984 foreach my $key (@$keys1) {
1001 =item Arguments: $relation
1003 =item Return value: Join condition arrayref
1007 Returns the join structure required for the related result source.
1012 my ($self, $join, $alias, $seen, $force_left) = @_;
1014 $force_left ||= { force => 0 };
1015 if (ref $join eq 'ARRAY') {
1016 return map { $self->resolve_join($_, $alias, $seen) } @$join;
1017 } elsif (ref $join eq 'HASH') {
1020 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
1021 local $force_left->{force};
1023 $self->resolve_join($_, $alias, $seen, $force_left),
1024 $self->related_source($_)->resolve_join(
1025 $join->{$_}, $as, $seen, $force_left
1029 } elsif (ref $join) {
1030 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1032 my $count = ++$seen->{$join};
1033 #use Data::Dumper; warn Dumper($seen);
1034 my $as = ($count > 1 ? "${join}_${count}" : $join);
1035 my $rel_info = $self->relationship_info($join);
1036 $self->throw_exception("No such relationship ${join}") unless $rel_info;
1038 if ($force_left->{force}) {
1041 $type = $rel_info->{attrs}{join_type} || '';
1042 $force_left->{force} = 1 if lc($type) eq 'left';
1044 return [ { $as => $self->related_source($join)->from,
1045 -join_type => $type },
1046 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
1050 =head2 pk_depends_on
1054 =item Arguments: $relname, $rel_data
1056 =item Return value: 1/0 (true/false)
1060 Determines whether a relation is dependent on an object from this source
1061 having already been inserted. Takes the name of the relationship and a
1062 hashref of columns of the related object.
1067 my ($self, $relname, $rel_data) = @_;
1068 my $cond = $self->relationship_info($relname)->{cond};
1070 return 0 unless ref($cond) eq 'HASH';
1072 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1074 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1076 # assume anything that references our PK probably is dependent on us
1077 # rather than vice versa, unless the far side is (a) defined or (b)
1080 my $rel_source = $self->related_source($relname);
1082 foreach my $p ($self->primary_columns) {
1083 if (exists $keyhash->{$p}) {
1084 unless (defined($rel_data->{$keyhash->{$p}})
1085 || $rel_source->column_info($keyhash->{$p})
1086 ->{is_auto_increment}) {
1095 =head2 resolve_condition
1099 =item Arguments: $cond, $as, $alias|$object
1103 Resolves the passed condition to a concrete query fragment. If given an alias,
1104 returns a join condition; if given an object, inverts that object to produce
1105 a related conditional from that object.
1109 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1111 sub resolve_condition {
1112 my ($self, $cond, $as, $for) = @_;
1114 if (ref $cond eq 'HASH') {
1116 foreach my $k (keys %{$cond}) {
1117 my $v = $cond->{$k};
1118 # XXX should probably check these are valid columns
1119 $k =~ s/^foreign\.// ||
1120 $self->throw_exception("Invalid rel cond key ${k}");
1121 $v =~ s/^self\.// ||
1122 $self->throw_exception("Invalid rel cond val ${v}");
1123 if (ref $for) { # Object
1124 #warn "$self $k $for $v";
1125 unless ($for->has_column_loaded($v)) {
1126 if ($for->in_storage) {
1127 $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
1129 return $UNRESOLVABLE_CONDITION;
1131 $ret{$k} = $for->get_column($v);
1132 #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1134 } elsif (!defined $for) { # undef, i.e. "no object"
1136 } elsif (ref $as eq 'HASH') { # reverse hashref
1137 $ret{$v} = $as->{$k};
1138 } elsif (ref $as) { # reverse object
1139 $ret{$v} = $as->get_column($k);
1140 } elsif (!defined $as) { # undef, i.e. "no reverse object"
1143 $ret{"${as}.${k}"} = "${for}.${v}";
1147 } elsif (ref $cond eq 'ARRAY') {
1148 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
1150 die("Can't handle this yet :(");
1154 =head2 resolve_prefetch
1158 =item Arguments: hashref/arrayref/scalar
1162 Accepts one or more relationships for the current source and returns an
1163 array of column names for each of those relationships. Column names are
1164 prefixed relative to the current source, in accordance with where they appear
1165 in the supplied relationships. Examples:
1167 my $source = $schema->resultset('Tag')->source;
1168 @columns = $source->resolve_prefetch( { cd => 'artist' } );
1176 # 'cd.artist.artistid',
1180 @columns = $source->resolve_prefetch( qw[/ cd /] );
1190 $source = $schema->resultset('CD')->source;
1191 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
1195 # 'artist.artistid',
1197 # 'producer.producerid',
1203 sub resolve_prefetch {
1204 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
1206 #$alias ||= $self->name;
1207 #warn $alias, Dumper $pre;
1208 if( ref $pre eq 'ARRAY' ) {
1210 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
1213 elsif( ref $pre eq 'HASH' ) {
1216 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
1217 $self->related_source($_)->resolve_prefetch(
1218 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
1224 $self->throw_exception(
1225 "don't know how to resolve prefetch reftype ".ref($pre));
1228 my $count = ++$seen->{$pre};
1229 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
1230 my $rel_info = $self->relationship_info( $pre );
1231 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1233 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1234 my $rel_source = $self->related_source($pre);
1236 if (exists $rel_info->{attrs}{accessor}
1237 && $rel_info->{attrs}{accessor} eq 'multi') {
1238 $self->throw_exception(
1239 "Can't prefetch has_many ${pre} (join cond too complex)")
1240 unless ref($rel_info->{cond}) eq 'HASH';
1241 my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1242 if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1243 keys %{$collapse}) {
1244 my ($last) = ($fail =~ /([^\.]+)$/);
1246 "Prefetching multiple has_many rels ${last} and ${pre} "
1247 .(length($as_prefix)
1248 ? "at the same level (${as_prefix}) "
1251 . 'will currently disrupt both the functionality of $rs->count(), '
1252 . 'and the amount of objects retrievable via $rs->next(). '
1253 . 'Use at your own risk.'
1256 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1257 # values %{$rel_info->{cond}};
1258 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1259 # action at a distance. prepending the '.' allows simpler code
1260 # in ResultSet->_collapse_result
1261 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1262 keys %{$rel_info->{cond}};
1263 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
1264 ? @{$rel_info->{attrs}{order_by}}
1265 : (defined $rel_info->{attrs}{order_by}
1266 ? ($rel_info->{attrs}{order_by})
1268 push(@$order, map { "${as}.$_" } (@key, @ord));
1271 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1272 $rel_source->columns;
1273 #warn $alias, Dumper (\@ret);
1278 =head2 related_source
1282 =item Arguments: $relname
1284 =item Return value: $source
1288 Returns the result source object for the given relationship.
1292 sub related_source {
1293 my ($self, $rel) = @_;
1294 if( !$self->has_relationship( $rel ) ) {
1295 $self->throw_exception("No such relationship '$rel'");
1297 return $self->schema->source($self->relationship_info($rel)->{source});
1300 =head2 related_class
1304 =item Arguments: $relname
1306 =item Return value: $classname
1310 Returns the class name for objects in the given relationship.
1315 my ($self, $rel) = @_;
1316 if( !$self->has_relationship( $rel ) ) {
1317 $self->throw_exception("No such relationship '$rel'");
1319 return $self->schema->class($self->relationship_info($rel)->{source});
1324 Obtain a new handle to this source. Returns an instance of a
1325 L<DBIx::Class::ResultSourceHandle>.
1330 return new DBIx::Class::ResultSourceHandle({
1331 schema => $_[0]->schema,
1332 source_moniker => $_[0]->source_name
1336 =head2 throw_exception
1338 See L<DBIx::Class::Schema/"throw_exception">.
1342 sub throw_exception {
1344 if (defined $self->schema) {
1345 $self->schema->throw_exception(@_);
1353 Stores a hashref of per-source metadata. No specific key names
1354 have yet been standardized, the examples below are purely hypothetical
1355 and don't actually accomplish anything on their own:
1357 __PACKAGE__->source_info({
1358 "_tablespace" => 'fast_disk_array_3',
1359 "_engine" => 'InnoDB',
1366 $class->new({attribute_name => value});
1368 Creates a new ResultSource object. Not normally called directly by end users.
1372 =head2 column_info_from_storage
1376 =item Arguments: 1/0 (default: 0)
1378 =item Return value: 1/0
1382 Enables the on-demand automatic loading of the above column
1383 metadata from storage as neccesary. This is *deprecated*, and
1384 should not be used. It will be removed before 1.0.
1386 __PACKAGE__->column_info_from_storage(1);
1390 =head2 sqlt_deploy_hook
1394 =item Arguments: $source, $sqlt_table
1396 =item Return value: undefined
1400 An optional sub which you can declare in your own Result class that will get
1401 passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1402 via L</create_ddl_dir> or L</deploy>.
1404 This is useful to make L<SQL::Translator> create non-unique indexes, or set
1405 table options such as C<Engine=INNODB>. For an example of what you can do with
1407 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1409 Note that sqlt_deploy_hook is called by
1410 L<DBIx::Class::Schema/deployment_statements>, which in turn is called before
1411 L<DBIx::Class::Schema/deploy>. Therefore the hook can be used only to manipulate
1412 the L<SQL::Translator::Table> object before it is turned into SQL fed to the
1413 database. If you want to execute post-deploy statements which can not be generated
1414 by L<SQL::Translator>, the currently suggested method is to overload
1415 L<DBIx::Class::Storage/deploy> and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
1417 Starting from DBIC 0.08100 a simple hook is inherited by all result sources, which
1418 invokes the method or coderef specified in L</sqlt_deploy_callback>. You can still
1419 overload this method like in older DBIC versions without any compatibility issues.
1423 sub sqlt_deploy_hook {
1425 if ( my $hook = $self->sqlt_deploy_callback) {
1430 =head2 sqlt_deploy_callback
1432 An attribute which contains the callback to trigger on C<sqlt_deploy_hook>.
1433 Defaults to C<default_sqlt_deploy_hook>. Can be a code reference or the name
1434 of a method in a result class. You would change the default value in case you
1435 want to share a hook between several result sources, or if you want to use a
1436 result source without a declared result class.
1438 =head2 default_sqlt_deploy_hook($table)
1440 Delegates to a an optional C<sqlt_deploy_hook> method on the C<result_class>.
1442 This will get passed the L<SQL::Translator::Schema::Table> object when you
1443 deploy the schema via L</create_ddl_dir> or L</deploy>.
1445 For an example of what you can do with this, see
1446 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1450 sub default_sqlt_deploy_hook {
1453 my $class = $self->result_class;
1455 if ($class and $class->can('sqlt_deploy_hook')) {
1456 $class->sqlt_deploy_hook(@_);
1463 Matt S. Trout <mst@shadowcatsystems.co.uk>
1467 You may distribute this code under the same terms as Perl itself.