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 column_info_from_storage source_name/);
17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
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>)
39 $class->new({attribute_name => value});
41 Creates a new ResultSource object. Not normally called directly by end users.
46 my ($class, $attrs) = @_;
47 $class = ref $class if ref $class;
48 my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
49 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
50 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
51 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
52 $new->{_columns} = { %{$new->{_columns}||{}} };
53 $new->{_relationships} = { %{$new->{_relationships}||{}} };
54 $new->{name} ||= "!!NAME NOT SET!!";
55 $new->{_columns_info_loaded} ||= 0;
63 $table->add_columns(qw/col1 col2 col3/);
65 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
67 Adds columns to the result source. If supplied key => hashref pairs, uses
68 the hashref as the column_info for that column. Repeated calls of this
69 method will add more columns, not replace them.
71 The contents of the column_info are not set in stone. The following
72 keys are currently recognised/used by DBIx::Class:
78 Use this to set the name of the accessor for this column. If unset,
79 the name of the column will be used.
83 This contains the column type. It is automatically filled by the
84 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
85 L<DBIx::Class::Schema::Loader> module. If you do not enter a
86 data_type, DBIx::Class will attempt to retrieve it from the
87 database for you, using L<DBI>'s column_info method. The values of this
88 key are typically upper-cased.
90 Currently there is no standard set of values for the data_type. Use
91 whatever your database supports.
95 The length of your column, if it is a column type that can have a size
96 restriction. This is currently not used by DBIx::Class.
100 Set this to a true value for a columns that is allowed to contain
101 NULL values. This is currently not used by DBIx::Class.
103 =item is_auto_increment
105 Set this to a true value for a column whose value is somehow
106 automatically set. This is used to determine which columns to empty
107 when cloning objects using C<copy>.
111 Set this to a true value for a column that contains a key from a
112 foreign table. This is currently not used by DBIx::Class.
116 Set this to the default value which will be inserted into a column
117 by the database. Can contain either a value or a function. This is
118 currently not used by DBIx::Class.
122 Set this on a primary key column to the name of the sequence used to
123 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
124 will attempt to retrieve the name of the sequence from the database
131 $table->add_column('col' => \%info?);
133 Convenience alias to add_columns.
138 my ($self, @cols) = @_;
139 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
142 my $columns = $self->_columns;
143 while (my $col = shift @cols) {
144 # If next entry is { ... } use that for the column info, if not
145 # use an empty hashref
146 my $column_info = ref $cols[0] ? shift(@cols) : {};
147 push(@added, $col) unless exists $columns->{$col};
148 $columns->{$col} = $column_info;
150 push @{ $self->_ordered_columns }, @added;
154 *add_column = \&add_columns;
158 if ($obj->has_column($col)) { ... }
160 Returns true if the source has a column of this name, false otherwise.
165 my ($self, $column) = @_;
166 return exists $self->_columns->{$column};
171 my $info = $obj->column_info($col);
173 Returns the column metadata hashref for a column. See the description
174 of add_column for information on the contents of the hashref.
179 my ($self, $column) = @_;
180 $self->throw_exception("No such column $column")
181 unless exists $self->_columns->{$column};
182 #warn $self->{_columns_info_loaded}, "\n";
183 if ( ! $self->_columns->{$column}{data_type}
184 and $self->column_info_from_storage
185 and ! $self->{_columns_info_loaded}
186 and $self->schema and $self->storage )
188 $self->{_columns_info_loaded}++;
191 # eval for the case of storage without table
192 eval { $info = $self->storage->columns_info_for( $self->from ) };
194 for my $realcol ( keys %{$info} ) {
195 $lc_info->{lc $realcol} = $info->{$realcol};
197 foreach my $col ( keys %{$self->_columns} ) {
198 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
202 return $self->_columns->{$column};
205 =head2 load_column_info_from_storage
207 Enables the on-demand automatic loading of the above column
208 metadata from storage as neccesary.
212 sub load_column_info_from_storage { shift->column_info_from_storage(1) }
216 my @column_names = $obj->columns;
218 Returns all column names in the order they were declared to add_columns.
224 $self->throw_exception(
225 "columns() is a read-only accessor, did you mean add_columns()?"
227 return @{$self->{_ordered_columns}||[]};
230 =head2 remove_columns
232 $table->remove_columns(qw/col1 col2 col3/);
234 Removes columns from the result source.
238 $table->remove_column('col');
240 Convenience alias to remove_columns.
245 my ($self, @cols) = @_;
247 return unless $self->_ordered_columns;
249 my $columns = $self->_columns;
252 foreach my $col (@{$self->_ordered_columns}) {
253 push @remaining, $col unless grep(/$col/, @cols);
257 undef $columns->{$_};
260 $self->_ordered_columns(\@remaining);
263 *remove_column = \&remove_columns;
265 =head2 set_primary_key
269 =item Arguments: @cols
273 Defines one or more columns as primary key for this source. Should be
274 called after C<add_columns>.
276 Additionally, defines a unique constraint named C<primary>.
278 The primary key columns are used by L<DBIx::Class::PK::Auto> to
279 retrieve automatically created values from the database.
283 sub set_primary_key {
284 my ($self, @cols) = @_;
285 # check if primary key columns are valid columns
286 foreach my $col (@cols) {
287 $self->throw_exception("No such column $col on table " . $self->name)
288 unless $self->has_column($col);
290 $self->_primaries(\@cols);
292 $self->add_unique_constraint(primary => \@cols);
295 =head2 primary_columns
297 Read-only accessor which returns the list of primary keys.
301 sub primary_columns {
302 return @{shift->_primaries||[]};
305 =head2 add_unique_constraint
307 Declare a unique constraint on this source. Call once for each unique
310 # For UNIQUE (column1, column2)
311 __PACKAGE__->add_unique_constraint(
312 constraint_name => [ qw/column1 column2/ ],
315 Alternatively, you can specify only the columns:
317 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
319 This will result in a unique constraint named C<table_column1_column2>, where
320 C<table> is replaced with the table name.
322 Unique constraints are used, for example, when you call
323 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
327 sub add_unique_constraint {
332 $name ||= $self->name_unique_constraint($cols);
334 foreach my $col (@$cols) {
335 $self->throw_exception("No such column $col on table " . $self->name)
336 unless $self->has_column($col);
339 my %unique_constraints = $self->unique_constraints;
340 $unique_constraints{$name} = $cols;
341 $self->_unique_constraints(\%unique_constraints);
344 =head2 name_unique_constraint
346 Return a name for a unique constraint containing the specified columns. These
347 names consist of the table name and each column name, separated by underscores.
349 For example, a constraint on a table named C<cd> containing the columns
350 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
354 sub name_unique_constraint {
355 my ($self, $cols) = @_;
357 return join '_', $self->name, @$cols;
360 =head2 unique_constraints
362 Read-only accessor which returns the list of unique constraints on this source.
366 sub unique_constraints {
367 return %{shift->_unique_constraints||{}};
370 =head2 unique_constraint_names
372 Returns the list of unique constraint names defined on this source.
376 sub unique_constraint_names {
379 my %unique_constraints = $self->unique_constraints;
381 return keys %unique_constraints;
384 =head2 unique_constraint_columns
386 Returns the list of columns that make up the specified unique constraint.
390 sub unique_constraint_columns {
391 my ($self, $constraint_name) = @_;
393 my %unique_constraints = $self->unique_constraints;
395 $self->throw_exception(
396 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
397 ) unless exists $unique_constraints{$constraint_name};
399 return @{ $unique_constraints{$constraint_name} };
404 Returns an expression of the source to be supplied to storage to specify
405 retrieval from this source. In the case of a database, the required FROM
410 Returns the L<DBIx::Class::Schema> object that this result source
415 Returns the storage handle for the current schema.
417 See also: L<DBIx::Class::Storage>
421 sub storage { shift->schema->storage; }
423 =head2 add_relationship
425 $source->add_relationship('relname', 'related_source', $cond, $attrs);
427 The relationship name can be arbitrary, but must be unique for each
428 relationship attached to this result source. 'related_source' should
429 be the name with which the related result source was registered with
430 the current schema. For example:
432 $schema->source('Book')->add_relationship('reviews', 'Review', {
433 'foreign.book_id' => 'self.id',
436 The condition C<$cond> needs to be an L<SQL::Abstract>-style
437 representation of the join between the tables. For example, if you're
438 creating a rel from Author to Book,
440 { 'foreign.author_id' => 'self.id' }
442 will result in the JOIN clause
444 author me JOIN book foreign ON foreign.author_id = me.id
446 You can specify as many foreign => self mappings as necessary.
448 Valid attributes are as follows:
454 Explicitly specifies the type of join to use in the relationship. Any
455 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
456 the SQL command immediately before C<JOIN>.
460 An arrayref containing a list of accessors in the foreign class to proxy in
461 the main class. If, for example, you do the following:
463 CD->might_have(liner_notes => 'LinerNotes', undef, {
464 proxy => [ qw/notes/ ],
467 Then, assuming LinerNotes has an accessor named notes, you can do:
469 my $cd = CD->find(1);
470 # set notes -- LinerNotes object is created if it doesn't exist
471 $cd->notes('Notes go here');
475 Specifies the type of accessor that should be created for the
476 relationship. Valid values are C<single> (for when there is only a single
477 related object), C<multi> (when there can be many), and C<filter> (for
478 when there is a single related object, but you also want the relationship
479 accessor to double as a column accessor). For C<multi> accessors, an
480 add_to_* method is also created, which calls C<create_related> for the
487 sub add_relationship {
488 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
489 $self->throw_exception("Can't create relationship without join condition")
493 my %rels = %{ $self->_relationships };
494 $rels{$rel} = { class => $f_source_name,
495 source => $f_source_name,
498 $self->_relationships(\%rels);
502 # XXX disabled. doesn't work properly currently. skip in tests.
504 my $f_source = $self->schema->source($f_source_name);
506 $self->ensure_class_loaded($f_source_name);
507 $f_source = $f_source_name->result_source;
508 #my $s_class = ref($self->schema);
509 #$f_source_name =~ m/^${s_class}::(.*)$/;
510 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
511 #$f_source = $self->schema->source($f_source_name);
513 return unless $f_source; # Can't test rel without f_source
515 eval { $self->resolve_join($rel, 'me') };
517 if ($@) { # If the resolve failed, back out and re-throw the error
518 delete $rels{$rel}; #
519 $self->_relationships(\%rels);
520 $self->throw_exception("Error creating relationship $rel: $@");
527 Returns all relationship names for this source.
532 return keys %{shift->_relationships};
535 =head2 relationship_info
539 =item Arguments: $relname
543 Returns a hash of relationship information for the specified relationship
548 sub relationship_info {
549 my ($self, $rel) = @_;
550 return $self->_relationships->{$rel};
553 =head2 has_relationship
557 =item Arguments: $rel
561 Returns true if the source has a relationship of this name, false otherwise.
565 sub has_relationship {
566 my ($self, $rel) = @_;
567 return exists $self->_relationships->{$rel};
570 =head2 reverse_relationship_info
574 =item Arguments: $relname
578 Returns an array of hash references of relationship information for
579 the other side of the specified relationship name.
583 sub reverse_relationship_info {
584 my ($self, $rel) = @_;
585 my $rel_info = $self->relationship_info($rel);
588 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
590 my @cond = keys(%{$rel_info->{cond}});
591 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
592 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
594 # Get the related result source for this relationship
595 my $othertable = $self->related_source($rel);
597 # Get all the relationships for that source that related to this source
598 # whose foreign column set are our self columns on $rel and whose self
599 # columns are our foreign columns on $rel.
600 my @otherrels = $othertable->relationships();
601 my $otherrelationship;
602 foreach my $otherrel (@otherrels) {
603 my $otherrel_info = $othertable->relationship_info($otherrel);
605 my $back = $othertable->related_source($otherrel);
606 next unless $back->name eq $self->name;
610 if (ref $otherrel_info->{cond} eq 'HASH') {
611 @othertestconds = ($otherrel_info->{cond});
613 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
614 @othertestconds = @{$otherrel_info->{cond}};
620 foreach my $othercond (@othertestconds) {
621 my @other_cond = keys(%$othercond);
622 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
623 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
624 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
625 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
626 $ret->{$otherrel} = $otherrel_info;
632 =head2 compare_relationship_keys
636 =item Arguments: $keys1, $keys2
640 Returns true if both sets of keynames are the same, false otherwise.
644 sub compare_relationship_keys {
645 my ($self, $keys1, $keys2) = @_;
647 # Make sure every keys1 is in keys2
649 foreach my $key (@$keys1) {
651 foreach my $prim (@$keys2) {
660 # Make sure every key2 is in key1
662 foreach my $prim (@$keys2) {
664 foreach my $key (@$keys1) {
681 =item Arguments: $relation
685 Returns the join structure required for the related result source.
690 my ($self, $join, $alias, $seen) = @_;
692 if (ref $join eq 'ARRAY') {
693 return map { $self->resolve_join($_, $alias, $seen) } @$join;
694 } elsif (ref $join eq 'HASH') {
697 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
698 ($self->resolve_join($_, $alias, $seen),
699 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
701 } elsif (ref $join) {
702 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
704 my $count = ++$seen->{$join};
705 #use Data::Dumper; warn Dumper($seen);
706 my $as = ($count > 1 ? "${join}_${count}" : $join);
707 my $rel_info = $self->relationship_info($join);
708 $self->throw_exception("No such relationship ${join}") unless $rel_info;
709 my $type = $rel_info->{attrs}{join_type} || '';
710 return [ { $as => $self->related_source($join)->from,
711 -join_type => $type },
712 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
716 =head2 resolve_condition
720 =item Arguments: $cond, $as, $alias|$object
724 Resolves the passed condition to a concrete query fragment. If given an alias,
725 returns a join condition; if given an object, inverts that object to produce
726 a related conditional from that object.
730 sub resolve_condition {
731 my ($self, $cond, $as, $for) = @_;
733 if (ref $cond eq 'HASH') {
735 foreach my $k (keys %{$cond}) {
737 # XXX should probably check these are valid columns
738 $k =~ s/^foreign\.// ||
739 $self->throw_exception("Invalid rel cond key ${k}");
741 $self->throw_exception("Invalid rel cond val ${v}");
742 if (ref $for) { # Object
743 #warn "$self $k $for $v";
744 $ret{$k} = $for->get_column($v);
746 } elsif (!defined $for) { # undef, i.e. "no object"
748 } elsif (ref $as) { # reverse object
749 $ret{$v} = $as->get_column($k);
750 } elsif (!defined $as) { # undef, i.e. "no reverse object"
753 $ret{"${as}.${k}"} = "${for}.${v}";
757 } elsif (ref $cond eq 'ARRAY') {
758 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
760 die("Can't handle this yet :(");
764 =head2 resolve_prefetch
768 =item Arguments: hashref/arrayref/scalar
772 Accepts one or more relationships for the current source and returns an
773 array of column names for each of those relationships. Column names are
774 prefixed relative to the current source, in accordance with where they appear
775 in the supplied relationships. Examples:
777 my $source = $schema->resultset('Tag')->source;
778 @columns = $source->resolve_prefetch( { cd => 'artist' } );
786 # 'cd.artist.artistid',
790 @columns = $source->resolve_prefetch( qw[/ cd /] );
800 $source = $schema->resultset('CD')->source;
801 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
807 # 'producer.producerid',
813 sub resolve_prefetch {
814 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
816 #$alias ||= $self->name;
817 #warn $alias, Dumper $pre;
818 if( ref $pre eq 'ARRAY' ) {
820 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
823 elsif( ref $pre eq 'HASH' ) {
826 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
827 $self->related_source($_)->resolve_prefetch(
828 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
834 $self->throw_exception(
835 "don't know how to resolve prefetch reftype ".ref($pre));
838 my $count = ++$seen->{$pre};
839 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
840 my $rel_info = $self->relationship_info( $pre );
841 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
843 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
844 my $rel_source = $self->related_source($pre);
846 if (exists $rel_info->{attrs}{accessor}
847 && $rel_info->{attrs}{accessor} eq 'multi') {
848 $self->throw_exception(
849 "Can't prefetch has_many ${pre} (join cond too complex)")
850 unless ref($rel_info->{cond}) eq 'HASH';
851 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
852 keys %{$rel_info->{cond}};
853 $collapse->{"${as_prefix}${pre}"} = \@key;
854 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
855 ? @{$rel_info->{attrs}{order_by}}
856 : (defined $rel_info->{attrs}{order_by}
857 ? ($rel_info->{attrs}{order_by})
859 push(@$order, map { "${as}.$_" } (@key, @ord));
862 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
863 $rel_source->columns;
864 #warn $alias, Dumper (\@ret);
869 =head2 related_source
873 =item Arguments: $relname
877 Returns the result source object for 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->source($self->relationship_info($rel)->{source});
893 =item Arguments: $relname
897 Returns the class name for objects in the given relationship.
902 my ($self, $rel) = @_;
903 if( !$self->has_relationship( $rel ) ) {
904 $self->throw_exception("No such relationship '$rel'");
906 return $self->schema->class($self->relationship_info($rel)->{source});
911 Returns a resultset for the given source. This will initially be created
914 $self->resultset_class->new($self, $self->resultset_attributes)
916 but is cached from then on unless resultset_class changes.
918 =head2 resultset_class
920 Set the class of the resultset, this is useful if you want to create your
921 own resultset methods. Create your own class derived from
922 L<DBIx::Class::ResultSet>, and set it here.
924 =head2 resultset_attributes
926 Specify here any attributes you wish to pass to your specialised resultset.
932 $self->throw_exception(
933 'resultset does not take any arguments. If you want another resultset, '.
934 'call it on the schema instead.'
937 # disabled until we can figure out a way to do it without consistency issues
939 #return $self->{_resultset}
940 # if ref $self->{_resultset} eq $self->resultset_class;
941 #return $self->{_resultset} =
943 return $self->resultset_class->new(
944 $self, $self->{resultset_attributes}
952 =item Arguments: $source_name
956 Set the name of the result source when it is loaded into a schema.
957 This is usefull if you want to refer to a result source by a name other than
960 package ArchivedBooks;
961 use base qw/DBIx::Class/;
962 __PACKAGE__->table('books_archive');
963 __PACKAGE__->source_name('Books');
965 # from your schema...
966 $schema->resultset('Books')->find(1);
968 =head2 throw_exception
970 See L<DBIx::Class::Schema/"throw_exception">.
974 sub throw_exception {
976 if (defined $self->schema) {
977 $self->schema->throw_exception(@_);
985 Matt S. Trout <mst@shadowcatsystems.co.uk>
989 You may distribute this code under the same terms as Perl itself.