1 package DBIx::Class::ResultSource;
6 use DBIx::Class::ResultSet;
7 use Carp::Clan qw/^DBIx::Class/;
10 use base qw/DBIx::Class/;
11 __PACKAGE__->load_components(qw/AccessorGroup/);
13 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
14 _columns _primaries _unique_constraints name resultset_attributes
15 schema from _relationships/);
17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
18 result_class source_name/);
22 DBIx::Class::ResultSource - Result source object
28 A ResultSource is a component of a schema from which results can be directly
29 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
36 my ($class, $attrs) = @_;
37 $class = ref $class if ref $class;
38 my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
39 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
40 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
41 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
42 $new->{_columns} = { %{$new->{_columns}||{}} };
43 $new->{_relationships} = { %{$new->{_relationships}||{}} };
44 $new->{name} ||= "!!NAME NOT SET!!";
45 $new->{_columns_info_loaded} ||= 0;
53 $table->add_columns(qw/col1 col2 col3/);
55 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
57 Adds columns to the result source. If supplied key => hashref pairs, uses
58 the hashref as the column_info for that column. Repeated calls of this
59 method will add more columns, not replace them.
61 The contents of the column_info are not set in stone. The following
62 keys are currently recognised/used by DBIx::Class:
68 Use this to set the name of the accessor for this column. If unset,
69 the name of the column will be used.
73 This contains the column type. It is automatically filled by the
74 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
75 L<DBIx::Class::Schema::Loader> module. If you do not enter a
76 data_type, DBIx::Class will attempt to retrieve it from the
77 database for you, using L<DBI>'s column_info method. The values of this
78 key are typically upper-cased.
80 Currently there is no standard set of values for the data_type. Use
81 whatever your database supports.
85 The length of your column, if it is a column type that can have a size
86 restriction. This is currently not used by DBIx::Class.
90 Set this to a true value for a columns that is allowed to contain
91 NULL values. This is currently not used by DBIx::Class.
93 =item is_auto_increment
95 Set this to a true value for a column whose value is somehow
96 automatically set. This is used to determine which columns to empty
97 when cloning objects using C<copy>.
101 Set this to a true value for a column that contains a key from a
102 foreign table. This is currently not used by DBIx::Class.
106 Set this to the default value which will be inserted into a column
107 by the database. Can contain either a value or a function. This is
108 currently not used by DBIx::Class.
112 Set this on a primary key column to the name of the sequence used to
113 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
114 will attempt to retrieve the name of the sequence from the database
121 $table->add_column('col' => \%info?);
123 Convenience alias to add_columns.
128 my ($self, @cols) = @_;
129 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
132 my $columns = $self->_columns;
133 while (my $col = shift @cols) {
134 # If next entry is { ... } use that for the column info, if not
135 # use an empty hashref
136 my $column_info = ref $cols[0] ? shift(@cols) : {};
137 push(@added, $col) unless exists $columns->{$col};
138 $columns->{$col} = $column_info;
140 push @{ $self->_ordered_columns }, @added;
144 *add_column = \&add_columns;
148 if ($obj->has_column($col)) { ... }
150 Returns true if the source has a column of this name, false otherwise.
155 my ($self, $column) = @_;
156 return exists $self->_columns->{$column};
161 my $info = $obj->column_info($col);
163 Returns the column metadata hashref for a column. See the description
164 of add_column for information on the contents of the hashref.
169 my ($self, $column) = @_;
170 $self->throw_exception("No such column $column")
171 unless exists $self->_columns->{$column};
172 #warn $self->{_columns_info_loaded}, "\n";
173 if ( ! $self->_columns->{$column}{data_type}
174 and ! $self->{_columns_info_loaded}
175 and $self->schema and $self->storage )
177 $self->{_columns_info_loaded}++;
180 # eval for the case of storage without table
181 eval { $info = $self->storage->columns_info_for( $self->from, keys %{$self->_columns} ) };
183 for my $realcol ( keys %{$info} ) {
184 $lc_info->{lc $realcol} = $info->{$realcol};
186 foreach my $col ( keys %{$self->_columns} ) {
187 $self->_columns->{$col} = $info->{$col} || $lc_info->{lc $col};
191 return $self->_columns->{$column};
196 my @column_names = $obj->columns;
198 Returns all column names in the order they were declared to add_columns.
204 $self->throw_exception(
205 "columns() is a read-only accessor, did you mean add_columns()?"
207 return @{$self->{_ordered_columns}||[]};
210 =head2 remove_columns
212 $table->remove_columns(qw/col1 col2 col3/);
214 Removes columns from the result source.
218 $table->remove_column('col');
220 Convenience alias to remove_columns.
225 my ($self, @cols) = @_;
227 return unless $self->_ordered_columns;
229 my $columns = $self->_columns;
232 foreach my $col (@{$self->_ordered_columns}) {
233 push @remaining, $col unless grep(/$col/, @cols);
237 undef $columns->{$_};
240 $self->_ordered_columns(\@remaining);
243 *remove_column = \&remove_columns;
245 =head2 set_primary_key
249 =item Arguments: @cols
253 Defines one or more columns as primary key for this source. Should be
254 called after C<add_columns>.
256 Additionally, defines a unique constraint named C<primary>.
258 The primary key columns are used by L<DBIx::Class::PK::Auto> to
259 retrieve automatically created values from the database.
263 sub set_primary_key {
264 my ($self, @cols) = @_;
265 # check if primary key columns are valid columns
266 foreach my $col (@cols) {
267 $self->throw_exception("No such column $col on table " . $self->name)
268 unless $self->has_column($col);
270 $self->_primaries(\@cols);
272 $self->add_unique_constraint(primary => \@cols);
275 =head2 primary_columns
277 Read-only accessor which returns the list of primary keys.
281 sub primary_columns {
282 return @{shift->_primaries||[]};
285 =head2 add_unique_constraint
287 Declare a unique constraint on this source. Call once for each unique
290 # For UNIQUE (column1, column2)
291 __PACKAGE__->add_unique_constraint(
292 constraint_name => [ qw/column1 column2/ ],
295 Alternatively, you can specify only the columns:
297 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
299 This will result in a unique constraint named C<table_column1_column2>, where
300 C<table> is replaced with the table name.
302 Unique constraints are used, for example, when you call
303 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
307 sub add_unique_constraint {
312 $name ||= $self->name_unique_constraint($cols);
314 foreach my $col (@$cols) {
315 $self->throw_exception("No such column $col on table " . $self->name)
316 unless $self->has_column($col);
319 my %unique_constraints = $self->unique_constraints;
320 $unique_constraints{$name} = $cols;
321 $self->_unique_constraints(\%unique_constraints);
324 =head2 name_unique_constraint
326 Return a name for a unique constraint containing the specified columns. These
327 names consist of the table name and each column name, separated by underscores.
329 For example, a constraint on a table named C<cd> containing the columns
330 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
334 sub name_unique_constraint {
335 my ($self, $cols) = @_;
337 return join '_', $self->name, @$cols;
340 =head2 unique_constraints
342 Read-only accessor which returns the list of unique constraints on this source.
346 sub unique_constraints {
347 return %{shift->_unique_constraints||{}};
350 =head2 unique_constraint_names
352 Returns the list of unique constraint names defined on this source.
356 sub unique_constraint_names {
359 my %unique_constraints = $self->unique_constraints;
361 return keys %unique_constraints;
364 =head2 unique_constraint_columns
366 Returns the list of columns that make up the specified unique constraint.
370 sub unique_constraint_columns {
371 my ($self, $constraint_name) = @_;
373 my %unique_constraints = $self->unique_constraints;
375 $self->throw_exception(
376 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
377 ) unless exists $unique_constraints{$constraint_name};
379 return @{ $unique_constraints{$constraint_name} };
384 Returns an expression of the source to be supplied to storage to specify
385 retrieval from this source. In the case of a database, the required FROM
390 Returns the L<DBIx::Class::Schema> object that this result source
395 Returns the storage handle for the current schema.
397 See also: L<DBIx::Class::Storage>
401 sub storage { shift->schema->storage; }
403 =head2 add_relationship
405 $source->add_relationship('relname', 'related_source', $cond, $attrs);
407 The relationship name can be arbitrary, but must be unique for each
408 relationship attached to this result source. 'related_source' should
409 be the name with which the related result source was registered with
410 the current schema. For example:
412 $schema->source('Book')->add_relationship('reviews', 'Review', {
413 'foreign.book_id' => 'self.id',
416 The condition C<$cond> needs to be an L<SQL::Abstract>-style
417 representation of the join between the tables. For example, if you're
418 creating a rel from Author to Book,
420 { 'foreign.author_id' => 'self.id' }
422 will result in the JOIN clause
424 author me JOIN book foreign ON foreign.author_id = me.id
426 You can specify as many foreign => self mappings as necessary.
428 Valid attributes are as follows:
434 Explicitly specifies the type of join to use in the relationship. Any
435 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
436 the SQL command immediately before C<JOIN>.
440 An arrayref containing a list of accessors in the foreign class to proxy in
441 the main class. If, for example, you do the following:
443 CD->might_have(liner_notes => 'LinerNotes', undef, {
444 proxy => [ qw/notes/ ],
447 Then, assuming LinerNotes has an accessor named notes, you can do:
449 my $cd = CD->find(1);
450 # set notes -- LinerNotes object is created if it doesn't exist
451 $cd->notes('Notes go here');
455 Specifies the type of accessor that should be created for the
456 relationship. Valid values are C<single> (for when there is only a single
457 related object), C<multi> (when there can be many), and C<filter> (for
458 when there is a single related object, but you also want the relationship
459 accessor to double as a column accessor). For C<multi> accessors, an
460 add_to_* method is also created, which calls C<create_related> for the
467 sub add_relationship {
468 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
469 $self->throw_exception("Can't create relationship without join condition")
473 my %rels = %{ $self->_relationships };
474 $rels{$rel} = { class => $f_source_name,
475 source => $f_source_name,
478 $self->_relationships(\%rels);
482 # XXX disabled. doesn't work properly currently. skip in tests.
484 my $f_source = $self->schema->source($f_source_name);
486 $self->ensure_class_loaded($f_source_name);
487 $f_source = $f_source_name->result_source;
488 #my $s_class = ref($self->schema);
489 #$f_source_name =~ m/^${s_class}::(.*)$/;
490 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
491 #$f_source = $self->schema->source($f_source_name);
493 return unless $f_source; # Can't test rel without f_source
495 eval { $self->resolve_join($rel, 'me') };
497 if ($@) { # If the resolve failed, back out and re-throw the error
498 delete $rels{$rel}; #
499 $self->_relationships(\%rels);
500 $self->throw_exception("Error creating relationship $rel: $@");
507 Returns all relationship names for this source.
512 return keys %{shift->_relationships};
515 =head2 relationship_info
519 =item Arguments: $relname
523 Returns a hash of relationship information for the specified relationship
528 sub relationship_info {
529 my ($self, $rel) = @_;
530 return $self->_relationships->{$rel};
533 =head2 has_relationship
537 =item Arguments: $rel
541 Returns true if the source has a relationship of this name, false otherwise.
545 sub has_relationship {
546 my ($self, $rel) = @_;
547 return exists $self->_relationships->{$rel};
550 =head2 reverse_relationship_info
554 =item Arguments: $relname
558 Returns an array of hash references of relationship information for
559 the other side of the specified relationship name.
563 sub reverse_relationship_info {
564 my ($self, $rel) = @_;
565 my $rel_info = $self->relationship_info($rel);
568 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
570 my @cond = keys(%{$rel_info->{cond}});
571 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
572 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
574 # Get the related result source for this relationship
575 my $othertable = $self->related_source($rel);
577 # Get all the relationships for that source that related to this source
578 # whose foreign column set are our self columns on $rel and whose self
579 # columns are our foreign columns on $rel.
580 my @otherrels = $othertable->relationships();
581 my $otherrelationship;
582 foreach my $otherrel (@otherrels) {
583 my $otherrel_info = $othertable->relationship_info($otherrel);
585 my $back = $othertable->related_source($otherrel);
586 next unless $back->name eq $self->name;
590 if (ref $otherrel_info->{cond} eq 'HASH') {
591 @othertestconds = ($otherrel_info->{cond});
593 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
594 @othertestconds = @{$otherrel_info->{cond}};
600 foreach my $othercond (@othertestconds) {
601 my @other_cond = keys(%$othercond);
602 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
603 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
604 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
605 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
606 $ret->{$otherrel} = $otherrel_info;
612 =head2 compare_relationship_keys
616 =item Arguments: $keys1, $keys2
620 Returns true if both sets of keynames are the same, false otherwise.
624 sub compare_relationship_keys {
625 my ($self, $keys1, $keys2) = @_;
627 # Make sure every keys1 is in keys2
629 foreach my $key (@$keys1) {
631 foreach my $prim (@$keys2) {
640 # Make sure every key2 is in key1
642 foreach my $prim (@$keys2) {
644 foreach my $key (@$keys1) {
661 =item Arguments: $relation
665 Returns the join structure required for the related result source.
670 my ($self, $join, $alias, $seen) = @_;
672 if (ref $join eq 'ARRAY') {
673 return map { $self->resolve_join($_, $alias, $seen) } @$join;
674 } elsif (ref $join eq 'HASH') {
677 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
678 ($self->resolve_join($_, $alias, $seen),
679 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
681 } elsif (ref $join) {
682 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
684 my $count = ++$seen->{$join};
685 #use Data::Dumper; warn Dumper($seen);
686 my $as = ($count > 1 ? "${join}_${count}" : $join);
687 my $rel_info = $self->relationship_info($join);
688 $self->throw_exception("No such relationship ${join}") unless $rel_info;
689 my $type = $rel_info->{attrs}{join_type} || '';
690 return [ { $as => $self->related_source($join)->from,
691 -join_type => $type },
692 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
696 =head2 resolve_condition
700 =item Arguments: $cond, $as, $alias|$object
704 Resolves the passed condition to a concrete query fragment. If given an alias,
705 returns a join condition; if given an object, inverts that object to produce
706 a related conditional from that object.
710 sub resolve_condition {
711 my ($self, $cond, $as, $for) = @_;
713 if (ref $cond eq 'HASH') {
715 foreach my $k (keys %{$cond}) {
717 # XXX should probably check these are valid columns
718 $k =~ s/^foreign\.// ||
719 $self->throw_exception("Invalid rel cond key ${k}");
721 $self->throw_exception("Invalid rel cond val ${v}");
722 if (ref $for) { # Object
723 #warn "$self $k $for $v";
724 $ret{$k} = $for->get_column($v);
726 } elsif (!defined $for) { # undef, i.e. "no object"
728 } elsif (ref $as) { # reverse object
729 $ret{$v} = $as->get_column($k);
730 } elsif (!defined $as) { # undef, i.e. "no reverse object"
733 $ret{"${as}.${k}"} = "${for}.${v}";
737 } elsif (ref $cond eq 'ARRAY') {
738 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
740 die("Can't handle this yet :(");
744 =head2 resolve_prefetch
748 =item Arguments: hashref/arrayref/scalar
752 Accepts one or more relationships for the current source and returns an
753 array of column names for each of those relationships. Column names are
754 prefixed relative to the current source, in accordance with where they appear
755 in the supplied relationships. Examples:
757 my $source = $schema->resultset('Tag')->source;
758 @columns = $source->resolve_prefetch( { cd => 'artist' } );
766 # 'cd.artist.artistid',
770 @columns = $source->resolve_prefetch( qw[/ cd /] );
780 $source = $schema->resultset('CD')->source;
781 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
787 # 'producer.producerid',
793 sub resolve_prefetch {
794 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
796 #$alias ||= $self->name;
797 #warn $alias, Dumper $pre;
798 if( ref $pre eq 'ARRAY' ) {
800 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
803 elsif( ref $pre eq 'HASH' ) {
806 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
807 $self->related_source($_)->resolve_prefetch(
808 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
814 $self->throw_exception(
815 "don't know how to resolve prefetch reftype ".ref($pre));
818 my $count = ++$seen->{$pre};
819 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
820 my $rel_info = $self->relationship_info( $pre );
821 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
823 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
824 my $rel_source = $self->related_source($pre);
826 if (exists $rel_info->{attrs}{accessor}
827 && $rel_info->{attrs}{accessor} eq 'multi') {
828 $self->throw_exception(
829 "Can't prefetch has_many ${pre} (join cond too complex)")
830 unless ref($rel_info->{cond}) eq 'HASH';
831 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
832 keys %{$rel_info->{cond}};
833 $collapse->{"${as_prefix}${pre}"} = \@key;
834 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
835 ? @{$rel_info->{attrs}{order_by}}
836 : (defined $rel_info->{attrs}{order_by}
837 ? ($rel_info->{attrs}{order_by})
839 push(@$order, map { "${as}.$_" } (@key, @ord));
842 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
843 $rel_source->columns;
844 #warn $alias, Dumper (\@ret);
849 =head2 related_source
853 =item Arguments: $relname
857 Returns the result source object for the given relationship.
862 my ($self, $rel) = @_;
863 if( !$self->has_relationship( $rel ) ) {
864 $self->throw_exception("No such relationship '$rel'");
866 return $self->schema->source($self->relationship_info($rel)->{source});
873 =item Arguments: $relname
877 Returns the class name for objects in the given relationship.
882 my ($self, $rel) = @_;
883 if( !$self->has_relationship( $rel ) ) {
884 $self->throw_exception("No such relationship '$rel'");
886 return $self->schema->class($self->relationship_info($rel)->{source});
891 Returns a resultset for the given source. This will initially be created
894 $self->resultset_class->new($self, $self->resultset_attributes)
896 but is cached from then on unless resultset_class changes.
898 =head2 resultset_class
900 Set the class of the resultset, this is useful if you want to create your
901 own resultset methods. Create your own class derived from
902 L<DBIx::Class::ResultSet>, and set it here.
904 =head2 resultset_attributes
906 Specify here any attributes you wish to pass to your specialised resultset.
912 $self->throw_exception(
913 'resultset does not take any arguments. If you want another resultset, '.
914 'call it on the schema instead.'
917 # disabled until we can figure out a way to do it without consistency issues
919 #return $self->{_resultset}
920 # if ref $self->{_resultset} eq $self->resultset_class;
921 #return $self->{_resultset} =
923 return $self->resultset_class->new(
924 $self, $self->{resultset_attributes}
932 =item Arguments: $source_name
936 Set the name of the result source when it is loaded into a schema.
937 This is usefull if you want to refer to a result source by a name other than
940 package ArchivedBooks;
941 use base qw/DBIx::Class/;
942 __PACKAGE__->table('books_archive');
943 __PACKAGE__->source_name('Books');
945 # from your schema...
946 $schema->resultset('Books')->find(1);
948 =head2 throw_exception
950 See L<DBIx::Class::Schema/"throw_exception">.
954 sub throw_exception {
956 if (defined $self->schema) {
957 $self->schema->throw_exception(@_);
965 Matt S. Trout <mst@shadowcatsystems.co.uk>
969 You may distribute this code under the same terms as Perl itself.