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;
67 Stores a hashref of per-source metadata. No specific key names
68 have yet been standardized, the examples below are purely hypothetical
69 and don't actually accomplish anything on their own:
71 __PACKAGE__->source_info({
72 "_tablespace" => 'fast_disk_array_3',
73 "_engine" => 'InnoDB',
78 $table->add_columns(qw/col1 col2 col3/);
80 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
82 Adds columns to the result source. If supplied key => hashref pairs, uses
83 the hashref as the column_info for that column. Repeated calls of this
84 method will add more columns, not replace them.
86 The contents of the column_info are not set in stone. The following
87 keys are currently recognised/used by DBIx::Class:
93 Use this to set the name of the accessor for this column. If unset,
94 the name of the column will be used.
98 This contains the column type. It is automatically filled by the
99 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
100 L<DBIx::Class::Schema::Loader> module. If you do not enter a
101 data_type, DBIx::Class will attempt to retrieve it from the
102 database for you, using L<DBI>'s column_info method. The values of this
103 key are typically upper-cased.
105 Currently there is no standard set of values for the data_type. Use
106 whatever your database supports.
110 The length of your column, if it is a column type that can have a size
111 restriction. This is currently not used by DBIx::Class.
115 Set this to a true value for a columns that is allowed to contain
116 NULL values. This is currently not used by DBIx::Class.
118 =item is_auto_increment
120 Set this to a true value for a column whose value is somehow
121 automatically set. This is used to determine which columns to empty
122 when cloning objects using C<copy>.
126 Set this to a true value for a column that contains a key from a
127 foreign table. This is currently not used by DBIx::Class.
131 Set this to the default value which will be inserted into a column
132 by the database. Can contain either a value or a function. This is
133 currently not used by DBIx::Class.
137 Set this on a primary key column to the name of the sequence used to
138 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
139 will attempt to retrieve the name of the sequence from the database
146 $table->add_column('col' => \%info?);
148 Convenience alias to add_columns.
153 my ($self, @cols) = @_;
154 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
157 my $columns = $self->_columns;
158 while (my $col = shift @cols) {
159 # If next entry is { ... } use that for the column info, if not
160 # use an empty hashref
161 my $column_info = ref $cols[0] ? shift(@cols) : {};
162 push(@added, $col) unless exists $columns->{$col};
163 $columns->{$col} = $column_info;
165 push @{ $self->_ordered_columns }, @added;
169 *add_column = \&add_columns;
173 if ($obj->has_column($col)) { ... }
175 Returns true if the source has a column of this name, false otherwise.
180 my ($self, $column) = @_;
181 return exists $self->_columns->{$column};
186 my $info = $obj->column_info($col);
188 Returns the column metadata hashref for a column. See the description
189 of add_column for information on the contents of the hashref.
194 my ($self, $column) = @_;
195 $self->throw_exception("No such column $column")
196 unless exists $self->_columns->{$column};
197 #warn $self->{_columns_info_loaded}, "\n";
198 if ( ! $self->_columns->{$column}{data_type}
199 and $self->column_info_from_storage
200 and ! $self->{_columns_info_loaded}
201 and $self->schema and $self->storage )
203 $self->{_columns_info_loaded}++;
206 # eval for the case of storage without table
207 eval { $info = $self->storage->columns_info_for( $self->from ) };
209 for my $realcol ( keys %{$info} ) {
210 $lc_info->{lc $realcol} = $info->{$realcol};
212 foreach my $col ( keys %{$self->_columns} ) {
213 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
217 return $self->_columns->{$column};
220 =head2 load_column_info_from_storage
222 Enables the on-demand automatic loading of the above column
223 metadata from storage as neccesary.
227 sub load_column_info_from_storage { shift->column_info_from_storage(1) }
231 my @column_names = $obj->columns;
233 Returns all column names in the order they were declared to add_columns.
239 $self->throw_exception(
240 "columns() is a read-only accessor, did you mean add_columns()?"
242 return @{$self->{_ordered_columns}||[]};
245 =head2 remove_columns
247 $table->remove_columns(qw/col1 col2 col3/);
249 Removes columns from the result source.
253 $table->remove_column('col');
255 Convenience alias to remove_columns.
260 my ($self, @cols) = @_;
262 return unless $self->_ordered_columns;
264 my $columns = $self->_columns;
267 foreach my $col (@{$self->_ordered_columns}) {
268 push @remaining, $col unless grep(/$col/, @cols);
272 delete $columns->{$_};
275 $self->_ordered_columns(\@remaining);
278 *remove_column = \&remove_columns;
280 =head2 set_primary_key
284 =item Arguments: @cols
288 Defines one or more columns as primary key for this source. Should be
289 called after C<add_columns>.
291 Additionally, defines a unique constraint named C<primary>.
293 The primary key columns are used by L<DBIx::Class::PK::Auto> to
294 retrieve automatically created values from the database.
298 sub set_primary_key {
299 my ($self, @cols) = @_;
300 # check if primary key columns are valid columns
301 foreach my $col (@cols) {
302 $self->throw_exception("No such column $col on table " . $self->name)
303 unless $self->has_column($col);
305 $self->_primaries(\@cols);
307 $self->add_unique_constraint(primary => \@cols);
310 =head2 primary_columns
312 Read-only accessor which returns the list of primary keys.
316 sub primary_columns {
317 return @{shift->_primaries||[]};
320 =head2 add_unique_constraint
322 Declare a unique constraint on this source. Call once for each unique
325 # For UNIQUE (column1, column2)
326 __PACKAGE__->add_unique_constraint(
327 constraint_name => [ qw/column1 column2/ ],
330 Alternatively, you can specify only the columns:
332 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
334 This will result in a unique constraint named C<table_column1_column2>, where
335 C<table> is replaced with the table name.
337 Unique constraints are used, for example, when you call
338 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
342 sub add_unique_constraint {
347 $name ||= $self->name_unique_constraint($cols);
349 foreach my $col (@$cols) {
350 $self->throw_exception("No such column $col on table " . $self->name)
351 unless $self->has_column($col);
354 my %unique_constraints = $self->unique_constraints;
355 $unique_constraints{$name} = $cols;
356 $self->_unique_constraints(\%unique_constraints);
359 =head2 name_unique_constraint
361 Return a name for a unique constraint containing the specified columns. These
362 names consist of the table name and each column name, separated by underscores.
364 For example, a constraint on a table named C<cd> containing the columns
365 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
369 sub name_unique_constraint {
370 my ($self, $cols) = @_;
372 return join '_', $self->name, @$cols;
375 =head2 unique_constraints
377 Read-only accessor which returns the list of unique constraints on this source.
381 sub unique_constraints {
382 return %{shift->_unique_constraints||{}};
385 =head2 unique_constraint_names
387 Returns the list of unique constraint names defined on this source.
391 sub unique_constraint_names {
394 my %unique_constraints = $self->unique_constraints;
396 return keys %unique_constraints;
399 =head2 unique_constraint_columns
401 Returns the list of columns that make up the specified unique constraint.
405 sub unique_constraint_columns {
406 my ($self, $constraint_name) = @_;
408 my %unique_constraints = $self->unique_constraints;
410 $self->throw_exception(
411 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
412 ) unless exists $unique_constraints{$constraint_name};
414 return @{ $unique_constraints{$constraint_name} };
419 Returns an expression of the source to be supplied to storage to specify
420 retrieval from this source. In the case of a database, the required FROM
425 Returns the L<DBIx::Class::Schema> object that this result source
430 Returns the storage handle for the current schema.
432 See also: L<DBIx::Class::Storage>
436 sub storage { shift->schema->storage; }
438 =head2 add_relationship
440 $source->add_relationship('relname', 'related_source', $cond, $attrs);
442 The relationship name can be arbitrary, but must be unique for each
443 relationship attached to this result source. 'related_source' should
444 be the name with which the related result source was registered with
445 the current schema. For example:
447 $schema->source('Book')->add_relationship('reviews', 'Review', {
448 'foreign.book_id' => 'self.id',
451 The condition C<$cond> needs to be an L<SQL::Abstract>-style
452 representation of the join between the tables. For example, if you're
453 creating a rel from Author to Book,
455 { 'foreign.author_id' => 'self.id' }
457 will result in the JOIN clause
459 author me JOIN book foreign ON foreign.author_id = me.id
461 You can specify as many foreign => self mappings as necessary.
463 Valid attributes are as follows:
469 Explicitly specifies the type of join to use in the relationship. Any
470 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
471 the SQL command immediately before C<JOIN>.
475 An arrayref containing a list of accessors in the foreign class to proxy in
476 the main class. If, for example, you do the following:
478 CD->might_have(liner_notes => 'LinerNotes', undef, {
479 proxy => [ qw/notes/ ],
482 Then, assuming LinerNotes has an accessor named notes, you can do:
484 my $cd = CD->find(1);
485 # set notes -- LinerNotes object is created if it doesn't exist
486 $cd->notes('Notes go here');
490 Specifies the type of accessor that should be created for the
491 relationship. Valid values are C<single> (for when there is only a single
492 related object), C<multi> (when there can be many), and C<filter> (for
493 when there is a single related object, but you also want the relationship
494 accessor to double as a column accessor). For C<multi> accessors, an
495 add_to_* method is also created, which calls C<create_related> for the
502 sub add_relationship {
503 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
504 $self->throw_exception("Can't create relationship without join condition")
508 my %rels = %{ $self->_relationships };
509 $rels{$rel} = { class => $f_source_name,
510 source => $f_source_name,
513 $self->_relationships(\%rels);
517 # XXX disabled. doesn't work properly currently. skip in tests.
519 my $f_source = $self->schema->source($f_source_name);
521 $self->ensure_class_loaded($f_source_name);
522 $f_source = $f_source_name->result_source;
523 #my $s_class = ref($self->schema);
524 #$f_source_name =~ m/^${s_class}::(.*)$/;
525 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
526 #$f_source = $self->schema->source($f_source_name);
528 return unless $f_source; # Can't test rel without f_source
530 eval { $self->resolve_join($rel, 'me') };
532 if ($@) { # If the resolve failed, back out and re-throw the error
533 delete $rels{$rel}; #
534 $self->_relationships(\%rels);
535 $self->throw_exception("Error creating relationship $rel: $@");
542 Returns all relationship names for this source.
547 return keys %{shift->_relationships};
550 =head2 relationship_info
554 =item Arguments: $relname
558 Returns a hash of relationship information for the specified relationship
563 sub relationship_info {
564 my ($self, $rel) = @_;
565 return $self->_relationships->{$rel};
568 =head2 has_relationship
572 =item Arguments: $rel
576 Returns true if the source has a relationship of this name, false otherwise.
580 sub has_relationship {
581 my ($self, $rel) = @_;
582 return exists $self->_relationships->{$rel};
585 =head2 reverse_relationship_info
589 =item Arguments: $relname
593 Returns an array of hash references of relationship information for
594 the other side of the specified relationship name.
598 sub reverse_relationship_info {
599 my ($self, $rel) = @_;
600 my $rel_info = $self->relationship_info($rel);
603 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
605 my @cond = keys(%{$rel_info->{cond}});
606 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
607 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
609 # Get the related result source for this relationship
610 my $othertable = $self->related_source($rel);
612 # Get all the relationships for that source that related to this source
613 # whose foreign column set are our self columns on $rel and whose self
614 # columns are our foreign columns on $rel.
615 my @otherrels = $othertable->relationships();
616 my $otherrelationship;
617 foreach my $otherrel (@otherrels) {
618 my $otherrel_info = $othertable->relationship_info($otherrel);
620 my $back = $othertable->related_source($otherrel);
621 next unless $back->name eq $self->name;
625 if (ref $otherrel_info->{cond} eq 'HASH') {
626 @othertestconds = ($otherrel_info->{cond});
628 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
629 @othertestconds = @{$otherrel_info->{cond}};
635 foreach my $othercond (@othertestconds) {
636 my @other_cond = keys(%$othercond);
637 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
638 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
639 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
640 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
641 $ret->{$otherrel} = $otherrel_info;
647 =head2 compare_relationship_keys
651 =item Arguments: $keys1, $keys2
655 Returns true if both sets of keynames are the same, false otherwise.
659 sub compare_relationship_keys {
660 my ($self, $keys1, $keys2) = @_;
662 # Make sure every keys1 is in keys2
664 foreach my $key (@$keys1) {
666 foreach my $prim (@$keys2) {
675 # Make sure every key2 is in key1
677 foreach my $prim (@$keys2) {
679 foreach my $key (@$keys1) {
696 =item Arguments: $relation
700 Returns the join structure required for the related result source.
705 my ($self, $join, $alias, $seen) = @_;
707 if (ref $join eq 'ARRAY') {
708 return map { $self->resolve_join($_, $alias, $seen) } @$join;
709 } elsif (ref $join eq 'HASH') {
712 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
713 ($self->resolve_join($_, $alias, $seen),
714 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
716 } elsif (ref $join) {
717 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
719 my $count = ++$seen->{$join};
720 #use Data::Dumper; warn Dumper($seen);
721 my $as = ($count > 1 ? "${join}_${count}" : $join);
722 my $rel_info = $self->relationship_info($join);
723 $self->throw_exception("No such relationship ${join}") unless $rel_info;
724 my $type = $rel_info->{attrs}{join_type} || '';
725 return [ { $as => $self->related_source($join)->from,
726 -join_type => $type },
727 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
731 =head2 resolve_condition
735 =item Arguments: $cond, $as, $alias|$object
739 Resolves the passed condition to a concrete query fragment. If given an alias,
740 returns a join condition; if given an object, inverts that object to produce
741 a related conditional from that object.
745 sub resolve_condition {
746 my ($self, $cond, $as, $for) = @_;
748 if (ref $cond eq 'HASH') {
750 foreach my $k (keys %{$cond}) {
752 # XXX should probably check these are valid columns
753 $k =~ s/^foreign\.// ||
754 $self->throw_exception("Invalid rel cond key ${k}");
756 $self->throw_exception("Invalid rel cond val ${v}");
757 if (ref $for) { # Object
758 #warn "$self $k $for $v";
759 $ret{$k} = $for->get_column($v);
761 } elsif (!defined $for) { # undef, i.e. "no object"
763 } elsif (ref $as) { # reverse object
764 $ret{$v} = $as->get_column($k);
765 } elsif (!defined $as) { # undef, i.e. "no reverse object"
768 $ret{"${as}.${k}"} = "${for}.${v}";
772 } elsif (ref $cond eq 'ARRAY') {
773 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
775 die("Can't handle this yet :(");
779 =head2 resolve_prefetch
783 =item Arguments: hashref/arrayref/scalar
787 Accepts one or more relationships for the current source and returns an
788 array of column names for each of those relationships. Column names are
789 prefixed relative to the current source, in accordance with where they appear
790 in the supplied relationships. Examples:
792 my $source = $schema->resultset('Tag')->source;
793 @columns = $source->resolve_prefetch( { cd => 'artist' } );
801 # 'cd.artist.artistid',
805 @columns = $source->resolve_prefetch( qw[/ cd /] );
815 $source = $schema->resultset('CD')->source;
816 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
822 # 'producer.producerid',
828 sub resolve_prefetch {
829 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
831 #$alias ||= $self->name;
832 #warn $alias, Dumper $pre;
833 if( ref $pre eq 'ARRAY' ) {
835 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
838 elsif( ref $pre eq 'HASH' ) {
841 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
842 $self->related_source($_)->resolve_prefetch(
843 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
849 $self->throw_exception(
850 "don't know how to resolve prefetch reftype ".ref($pre));
853 my $count = ++$seen->{$pre};
854 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
855 my $rel_info = $self->relationship_info( $pre );
856 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
858 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
859 my $rel_source = $self->related_source($pre);
861 if (exists $rel_info->{attrs}{accessor}
862 && $rel_info->{attrs}{accessor} eq 'multi') {
863 $self->throw_exception(
864 "Can't prefetch has_many ${pre} (join cond too complex)")
865 unless ref($rel_info->{cond}) eq 'HASH';
866 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
867 keys %{$rel_info->{cond}};
868 $collapse->{"${as_prefix}${pre}"} = \@key;
869 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
870 ? @{$rel_info->{attrs}{order_by}}
871 : (defined $rel_info->{attrs}{order_by}
872 ? ($rel_info->{attrs}{order_by})
874 push(@$order, map { "${as}.$_" } (@key, @ord));
877 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
878 $rel_source->columns;
879 #warn $alias, Dumper (\@ret);
884 =head2 related_source
888 =item Arguments: $relname
892 Returns the result source object for the given relationship.
897 my ($self, $rel) = @_;
898 if( !$self->has_relationship( $rel ) ) {
899 $self->throw_exception("No such relationship '$rel'");
901 return $self->schema->source($self->relationship_info($rel)->{source});
908 =item Arguments: $relname
912 Returns the class name for objects in the given relationship.
917 my ($self, $rel) = @_;
918 if( !$self->has_relationship( $rel ) ) {
919 $self->throw_exception("No such relationship '$rel'");
921 return $self->schema->class($self->relationship_info($rel)->{source});
926 Returns a resultset for the given source. This will initially be created
929 $self->resultset_class->new($self, $self->resultset_attributes)
931 but is cached from then on unless resultset_class changes.
933 =head2 resultset_class
935 Set the class of the resultset, this is useful if you want to create your
936 own resultset methods. Create your own class derived from
937 L<DBIx::Class::ResultSet>, and set it here.
939 =head2 resultset_attributes
941 Specify here any attributes you wish to pass to your specialised resultset.
947 $self->throw_exception(
948 'resultset does not take any arguments. If you want another resultset, '.
949 'call it on the schema instead.'
952 # disabled until we can figure out a way to do it without consistency issues
954 #return $self->{_resultset}
955 # if ref $self->{_resultset} eq $self->resultset_class;
956 #return $self->{_resultset} =
958 return $self->resultset_class->new(
959 $self, $self->{resultset_attributes}
967 =item Arguments: $source_name
971 Set the name of the result source when it is loaded into a schema.
972 This is usefull if you want to refer to a result source by a name other than
975 package ArchivedBooks;
976 use base qw/DBIx::Class/;
977 __PACKAGE__->table('books_archive');
978 __PACKAGE__->source_name('Books');
980 # from your schema...
981 $schema->resultset('Books')->find(1);
983 =head2 throw_exception
985 See L<DBIx::Class::Schema/"throw_exception">.
989 sub throw_exception {
991 if (defined $self->schema) {
992 $self->schema->throw_exception(@_);
1000 Matt S. Trout <mst@shadowcatsystems.co.uk>
1004 You may distribute this code under the same terms as Perl itself.