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
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>)
40 $class->new({attribute_name => value});
42 Creates a new ResultSource object. Not normally called directly by end users.
47 my ($class, $attrs) = @_;
48 $class = ref $class if ref $class;
50 my $new = { %{$attrs || {}}, _resultset => undef };
53 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
54 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
55 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
56 $new->{_columns} = { %{$new->{_columns}||{}} };
57 $new->{_relationships} = { %{$new->{_relationships}||{}} };
58 $new->{name} ||= "!!NAME NOT SET!!";
59 $new->{_columns_info_loaded} ||= 0;
60 if(!defined $new->column_info_from_storage) {
61 $new->{column_info_from_storage} = 1
70 Stores a hashref of per-source metadata. No specific key names
71 have yet been standardized, the examples below are purely hypothetical
72 and don't actually accomplish anything on their own:
74 __PACKAGE__->source_info({
75 "_tablespace" => 'fast_disk_array_3',
76 "_engine" => 'InnoDB',
81 $table->add_columns(qw/col1 col2 col3/);
83 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
85 Adds columns to the result source. If supplied key => hashref pairs, uses
86 the hashref as the column_info for that column. Repeated calls of this
87 method will add more columns, not replace them.
89 The contents of the column_info are not set in stone. The following
90 keys are currently recognised/used by DBIx::Class:
96 Use this to set the name of the accessor for this column. If unset,
97 the name of the column will be used.
101 This contains the column type. It is automatically filled by the
102 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
103 L<DBIx::Class::Schema::Loader> module. If you do not enter a
104 data_type, DBIx::Class will attempt to retrieve it from the
105 database for you, using L<DBI>'s column_info method. The values of this
106 key are typically upper-cased.
108 Currently there is no standard set of values for the data_type. Use
109 whatever your database supports.
113 The length of your column, if it is a column type that can have a size
114 restriction. This is currently not used by DBIx::Class.
118 Set this to a true value for a columns that is allowed to contain
119 NULL values. This is currently not used by DBIx::Class.
121 =item is_auto_increment
123 Set this to a true value for a column whose value is somehow
124 automatically set. This is used to determine which columns to empty
125 when cloning objects using C<copy>.
129 Set this to a true value for a column that contains a key from a
130 foreign table. This is currently not used by DBIx::Class.
134 Set this to the default value which will be inserted into a column
135 by the database. Can contain either a value or a function. This is
136 currently not used by DBIx::Class.
140 Set this on a primary key column to the name of the sequence used to
141 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
142 will attempt to retrieve the name of the sequence from the database
149 $table->add_column('col' => \%info?);
151 Convenience alias to add_columns.
156 my ($self, @cols) = @_;
157 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
160 my $columns = $self->_columns;
161 while (my $col = shift @cols) {
162 # If next entry is { ... } use that for the column info, if not
163 # use an empty hashref
164 my $column_info = ref $cols[0] ? shift(@cols) : {};
165 push(@added, $col) unless exists $columns->{$col};
166 $columns->{$col} = $column_info;
168 push @{ $self->_ordered_columns }, @added;
172 *add_column = \&add_columns;
176 if ($obj->has_column($col)) { ... }
178 Returns true if the source has a column of this name, false otherwise.
183 my ($self, $column) = @_;
184 return exists $self->_columns->{$column};
189 my $info = $obj->column_info($col);
191 Returns the column metadata hashref for a column. See the description
192 of add_column for information on the contents of the hashref.
197 my ($self, $column) = @_;
198 $self->throw_exception("No such column $column")
199 unless exists $self->_columns->{$column};
200 #warn $self->{_columns_info_loaded}, "\n";
201 if ( ! $self->_columns->{$column}{data_type}
202 and $self->column_info_from_storage
203 and ! $self->{_columns_info_loaded}
204 and $self->schema and $self->storage )
206 $self->{_columns_info_loaded}++;
209 # eval for the case of storage without table
210 eval { $info = $self->storage->columns_info_for( $self->from ) };
212 for my $realcol ( keys %{$info} ) {
213 $lc_info->{lc $realcol} = $info->{$realcol};
215 foreach my $col ( keys %{$self->_columns} ) {
216 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
220 return $self->_columns->{$column};
223 =head2 column_info_from_storage
225 Enables the on-demand automatic loading of the above column
226 metadata from storage as neccesary. This is *deprecated*, and
227 should not be used. It will be removed before 1.0.
229 __PACKAGE__->column_info_from_storage(1);
233 my @column_names = $obj->columns;
235 Returns all column names in the order they were declared to add_columns.
241 $self->throw_exception(
242 "columns() is a read-only accessor, did you mean add_columns()?"
244 return @{$self->{_ordered_columns}||[]};
247 =head2 remove_columns
249 $table->remove_columns(qw/col1 col2 col3/);
251 Removes columns from the result source.
255 $table->remove_column('col');
257 Convenience alias to remove_columns.
262 my ($self, @cols) = @_;
264 return unless $self->_ordered_columns;
266 my $columns = $self->_columns;
269 foreach my $col (@{$self->_ordered_columns}) {
270 push @remaining, $col unless grep(/$col/, @cols);
274 delete $columns->{$_};
277 $self->_ordered_columns(\@remaining);
280 *remove_column = \&remove_columns;
282 =head2 set_primary_key
286 =item Arguments: @cols
290 Defines one or more columns as primary key for this source. Should be
291 called after C<add_columns>.
293 Additionally, defines a unique constraint named C<primary>.
295 The primary key columns are used by L<DBIx::Class::PK::Auto> to
296 retrieve automatically created values from the database.
300 sub set_primary_key {
301 my ($self, @cols) = @_;
302 # check if primary key columns are valid columns
303 foreach my $col (@cols) {
304 $self->throw_exception("No such column $col on table " . $self->name)
305 unless $self->has_column($col);
307 $self->_primaries(\@cols);
309 $self->add_unique_constraint(primary => \@cols);
312 =head2 primary_columns
314 Read-only accessor which returns the list of primary keys.
318 sub primary_columns {
319 return @{shift->_primaries||[]};
322 =head2 add_unique_constraint
324 Declare a unique constraint on this source. Call once for each unique
327 # For UNIQUE (column1, column2)
328 __PACKAGE__->add_unique_constraint(
329 constraint_name => [ qw/column1 column2/ ],
332 Alternatively, you can specify only the columns:
334 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
336 This will result in a unique constraint named C<table_column1_column2>, where
337 C<table> is replaced with the table name.
339 Unique constraints are used, for example, when you call
340 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
344 sub add_unique_constraint {
349 $name ||= $self->name_unique_constraint($cols);
351 foreach my $col (@$cols) {
352 $self->throw_exception("No such column $col on table " . $self->name)
353 unless $self->has_column($col);
356 my %unique_constraints = $self->unique_constraints;
357 $unique_constraints{$name} = $cols;
358 $self->_unique_constraints(\%unique_constraints);
361 =head2 name_unique_constraint
363 Return a name for a unique constraint containing the specified columns. These
364 names consist of the table name and each column name, separated by underscores.
366 For example, a constraint on a table named C<cd> containing the columns
367 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
371 sub name_unique_constraint {
372 my ($self, $cols) = @_;
374 return join '_', $self->name, @$cols;
377 =head2 unique_constraints
379 Read-only accessor which returns the list of unique constraints on this source.
383 sub unique_constraints {
384 return %{shift->_unique_constraints||{}};
387 =head2 unique_constraint_names
389 Returns the list of unique constraint names defined on this source.
393 sub unique_constraint_names {
396 my %unique_constraints = $self->unique_constraints;
398 return keys %unique_constraints;
401 =head2 unique_constraint_columns
403 Returns the list of columns that make up the specified unique constraint.
407 sub unique_constraint_columns {
408 my ($self, $constraint_name) = @_;
410 my %unique_constraints = $self->unique_constraints;
412 $self->throw_exception(
413 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
414 ) unless exists $unique_constraints{$constraint_name};
416 return @{ $unique_constraints{$constraint_name} };
421 Returns an expression of the source to be supplied to storage to specify
422 retrieval from this source. In the case of a database, the required FROM
427 Returns the L<DBIx::Class::Schema> object that this result source
432 Returns the storage handle for the current schema.
434 See also: L<DBIx::Class::Storage>
438 sub storage { shift->schema->storage; }
440 =head2 add_relationship
442 $source->add_relationship('relname', 'related_source', $cond, $attrs);
444 The relationship name can be arbitrary, but must be unique for each
445 relationship attached to this result source. 'related_source' should
446 be the name with which the related result source was registered with
447 the current schema. For example:
449 $schema->source('Book')->add_relationship('reviews', 'Review', {
450 'foreign.book_id' => 'self.id',
453 The condition C<$cond> needs to be an L<SQL::Abstract>-style
454 representation of the join between the tables. For example, if you're
455 creating a rel from Author to Book,
457 { 'foreign.author_id' => 'self.id' }
459 will result in the JOIN clause
461 author me JOIN book foreign ON foreign.author_id = me.id
463 You can specify as many foreign => self mappings as necessary.
465 Valid attributes are as follows:
471 Explicitly specifies the type of join to use in the relationship. Any
472 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
473 the SQL command immediately before C<JOIN>.
477 An arrayref containing a list of accessors in the foreign class to proxy in
478 the main class. If, for example, you do the following:
480 CD->might_have(liner_notes => 'LinerNotes', undef, {
481 proxy => [ qw/notes/ ],
484 Then, assuming LinerNotes has an accessor named notes, you can do:
486 my $cd = CD->find(1);
487 # set notes -- LinerNotes object is created if it doesn't exist
488 $cd->notes('Notes go here');
492 Specifies the type of accessor that should be created for the
493 relationship. Valid values are C<single> (for when there is only a single
494 related object), C<multi> (when there can be many), and C<filter> (for
495 when there is a single related object, but you also want the relationship
496 accessor to double as a column accessor). For C<multi> accessors, an
497 add_to_* method is also created, which calls C<create_related> for the
504 sub add_relationship {
505 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
506 $self->throw_exception("Can't create relationship without join condition")
510 my %rels = %{ $self->_relationships };
511 $rels{$rel} = { class => $f_source_name,
512 source => $f_source_name,
515 $self->_relationships(\%rels);
519 # XXX disabled. doesn't work properly currently. skip in tests.
521 my $f_source = $self->schema->source($f_source_name);
523 $self->ensure_class_loaded($f_source_name);
524 $f_source = $f_source_name->result_source;
525 #my $s_class = ref($self->schema);
526 #$f_source_name =~ m/^${s_class}::(.*)$/;
527 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
528 #$f_source = $self->schema->source($f_source_name);
530 return unless $f_source; # Can't test rel without f_source
532 eval { $self->resolve_join($rel, 'me') };
534 if ($@) { # If the resolve failed, back out and re-throw the error
535 delete $rels{$rel}; #
536 $self->_relationships(\%rels);
537 $self->throw_exception("Error creating relationship $rel: $@");
544 Returns all relationship names for this source.
549 return keys %{shift->_relationships};
552 =head2 relationship_info
556 =item Arguments: $relname
560 Returns a hash of relationship information for the specified relationship
565 sub relationship_info {
566 my ($self, $rel) = @_;
567 return $self->_relationships->{$rel};
570 =head2 has_relationship
574 =item Arguments: $rel
578 Returns true if the source has a relationship of this name, false otherwise.
582 sub has_relationship {
583 my ($self, $rel) = @_;
584 return exists $self->_relationships->{$rel};
587 =head2 reverse_relationship_info
591 =item Arguments: $relname
595 Returns an array of hash references of relationship information for
596 the other side of the specified relationship name.
600 sub reverse_relationship_info {
601 my ($self, $rel) = @_;
602 my $rel_info = $self->relationship_info($rel);
605 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
607 my @cond = keys(%{$rel_info->{cond}});
608 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
609 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
611 # Get the related result source for this relationship
612 my $othertable = $self->related_source($rel);
614 # Get all the relationships for that source that related to this source
615 # whose foreign column set are our self columns on $rel and whose self
616 # columns are our foreign columns on $rel.
617 my @otherrels = $othertable->relationships();
618 my $otherrelationship;
619 foreach my $otherrel (@otherrels) {
620 my $otherrel_info = $othertable->relationship_info($otherrel);
622 my $back = $othertable->related_source($otherrel);
623 next unless $back->name eq $self->name;
627 if (ref $otherrel_info->{cond} eq 'HASH') {
628 @othertestconds = ($otherrel_info->{cond});
630 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
631 @othertestconds = @{$otherrel_info->{cond}};
637 foreach my $othercond (@othertestconds) {
638 my @other_cond = keys(%$othercond);
639 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
640 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
641 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
642 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
643 $ret->{$otherrel} = $otherrel_info;
649 =head2 compare_relationship_keys
653 =item Arguments: $keys1, $keys2
657 Returns true if both sets of keynames are the same, false otherwise.
661 sub compare_relationship_keys {
662 my ($self, $keys1, $keys2) = @_;
664 # Make sure every keys1 is in keys2
666 foreach my $key (@$keys1) {
668 foreach my $prim (@$keys2) {
677 # Make sure every key2 is in key1
679 foreach my $prim (@$keys2) {
681 foreach my $key (@$keys1) {
698 =item Arguments: $relation
702 Returns the join structure required for the related result source.
707 my ($self, $join, $alias, $seen) = @_;
709 if (ref $join eq 'ARRAY') {
710 return map { $self->resolve_join($_, $alias, $seen) } @$join;
711 } elsif (ref $join eq 'HASH') {
714 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
715 ($self->resolve_join($_, $alias, $seen),
716 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
718 } elsif (ref $join) {
719 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
721 my $count = ++$seen->{$join};
722 #use Data::Dumper; warn Dumper($seen);
723 my $as = ($count > 1 ? "${join}_${count}" : $join);
724 my $rel_info = $self->relationship_info($join);
725 $self->throw_exception("No such relationship ${join}") unless $rel_info;
726 my $type = $rel_info->{attrs}{join_type} || '';
727 return [ { $as => $self->related_source($join)->from,
728 -join_type => $type },
729 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
733 =head2 resolve_condition
737 =item Arguments: $cond, $as, $alias|$object
741 Resolves the passed condition to a concrete query fragment. If given an alias,
742 returns a join condition; if given an object, inverts that object to produce
743 a related conditional from that object.
747 sub resolve_condition {
748 my ($self, $cond, $as, $for) = @_;
750 if (ref $cond eq 'HASH') {
752 foreach my $k (keys %{$cond}) {
754 # XXX should probably check these are valid columns
755 $k =~ s/^foreign\.// ||
756 $self->throw_exception("Invalid rel cond key ${k}");
758 $self->throw_exception("Invalid rel cond val ${v}");
759 if (ref $for) { # Object
760 #warn "$self $k $for $v";
761 $ret{$k} = $for->get_column($v);
763 } elsif (!defined $for) { # undef, i.e. "no object"
765 } elsif (ref $as) { # reverse object
766 $ret{$v} = $as->get_column($k);
767 } elsif (!defined $as) { # undef, i.e. "no reverse object"
770 $ret{"${as}.${k}"} = "${for}.${v}";
774 } elsif (ref $cond eq 'ARRAY') {
775 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
777 die("Can't handle this yet :(");
781 =head2 resolve_prefetch
785 =item Arguments: hashref/arrayref/scalar
789 Accepts one or more relationships for the current source and returns an
790 array of column names for each of those relationships. Column names are
791 prefixed relative to the current source, in accordance with where they appear
792 in the supplied relationships. Examples:
794 my $source = $schema->resultset('Tag')->source;
795 @columns = $source->resolve_prefetch( { cd => 'artist' } );
803 # 'cd.artist.artistid',
807 @columns = $source->resolve_prefetch( qw[/ cd /] );
817 $source = $schema->resultset('CD')->source;
818 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
824 # 'producer.producerid',
830 sub resolve_prefetch {
831 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
833 #$alias ||= $self->name;
834 #warn $alias, Dumper $pre;
835 if( ref $pre eq 'ARRAY' ) {
837 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
840 elsif( ref $pre eq 'HASH' ) {
843 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
844 $self->related_source($_)->resolve_prefetch(
845 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
851 $self->throw_exception(
852 "don't know how to resolve prefetch reftype ".ref($pre));
855 my $count = ++$seen->{$pre};
856 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
857 my $rel_info = $self->relationship_info( $pre );
858 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
860 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
861 my $rel_source = $self->related_source($pre);
863 if (exists $rel_info->{attrs}{accessor}
864 && $rel_info->{attrs}{accessor} eq 'multi') {
865 $self->throw_exception(
866 "Can't prefetch has_many ${pre} (join cond too complex)")
867 unless ref($rel_info->{cond}) eq 'HASH';
868 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
869 keys %{$rel_info->{cond}};
870 $collapse->{"${as_prefix}${pre}"} = \@key;
871 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
872 ? @{$rel_info->{attrs}{order_by}}
873 : (defined $rel_info->{attrs}{order_by}
874 ? ($rel_info->{attrs}{order_by})
876 push(@$order, map { "${as}.$_" } (@key, @ord));
879 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
880 $rel_source->columns;
881 #warn $alias, Dumper (\@ret);
886 =head2 related_source
890 =item Arguments: $relname
894 Returns the result source object for the given relationship.
899 my ($self, $rel) = @_;
900 if( !$self->has_relationship( $rel ) ) {
901 $self->throw_exception("No such relationship '$rel'");
903 return $self->schema->source($self->relationship_info($rel)->{source});
910 =item Arguments: $relname
914 Returns the class name for objects in the given relationship.
919 my ($self, $rel) = @_;
920 if( !$self->has_relationship( $rel ) ) {
921 $self->throw_exception("No such relationship '$rel'");
923 return $self->schema->class($self->relationship_info($rel)->{source});
928 Returns a resultset for the given source. This will initially be created
931 $self->resultset_class->new($self, $self->resultset_attributes)
933 but is cached from then on unless resultset_class changes.
935 =head2 resultset_class
937 Set the class of the resultset, this is useful if you want to create your
938 own resultset methods. Create your own class derived from
939 L<DBIx::Class::ResultSet>, and set it here.
941 =head2 resultset_attributes
943 Specify here any attributes you wish to pass to your specialised resultset.
949 $self->throw_exception(
950 'resultset does not take any arguments. If you want another resultset, '.
951 'call it on the schema instead.'
954 # disabled until we can figure out a way to do it without consistency issues
956 #return $self->{_resultset}
957 # if ref $self->{_resultset} eq $self->resultset_class;
958 #return $self->{_resultset} =
960 return $self->resultset_class->new(
961 $self, $self->{resultset_attributes}
969 =item Arguments: $source_name
973 Set the name of the result source when it is loaded into a schema.
974 This is usefull if you want to refer to a result source by a name other than
977 package ArchivedBooks;
978 use base qw/DBIx::Class/;
979 __PACKAGE__->table('books_archive');
980 __PACKAGE__->source_name('Books');
982 # from your schema...
983 $schema->resultset('Books')->find(1);
985 =head2 throw_exception
987 See L<DBIx::Class::Schema/"throw_exception">.
991 sub throw_exception {
993 if (defined $self->schema) {
994 $self->schema->throw_exception(@_);
1002 Matt S. Trout <mst@shadowcatsystems.co.uk>
1006 You may distribute this code under the same terms as Perl itself.