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;
49 my $new = { %{$attrs || {}}, _resultset => undef };
52 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
53 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
54 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
55 $new->{_columns} = { %{$new->{_columns}||{}} };
56 $new->{_relationships} = { %{$new->{_relationships}||{}} };
57 $new->{name} ||= "!!NAME NOT SET!!";
58 $new->{_columns_info_loaded} ||= 0;
66 $table->add_columns(qw/col1 col2 col3/);
68 $table->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 contents of the column_info are not set in stone. The following
75 keys are currently recognised/used by DBIx::Class:
81 Use this to set the name of the accessor for this column. If unset,
82 the name of the column will be used.
86 This contains the column type. It is automatically filled by the
87 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
88 L<DBIx::Class::Schema::Loader> module. If you do not enter a
89 data_type, DBIx::Class will attempt to retrieve it from the
90 database for you, using L<DBI>'s column_info method. The values of this
91 key are typically upper-cased.
93 Currently there is no standard set of values for the data_type. Use
94 whatever your database supports.
98 The length of your column, if it is a column type that can have a size
99 restriction. This is currently not used by DBIx::Class.
103 Set this to a true value for a columns that is allowed to contain
104 NULL values. This is currently not used by DBIx::Class.
106 =item is_auto_increment
108 Set this to a true value for a column whose value is somehow
109 automatically set. This is used to determine which columns to empty
110 when cloning objects using C<copy>.
114 Set this to a true value for a column that contains a key from a
115 foreign table. This is currently not used by DBIx::Class.
119 Set this to the default value which will be inserted into a column
120 by the database. Can contain either a value or a function. This is
121 currently not used by DBIx::Class.
125 Set this on a primary key column to the name of the sequence used to
126 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
127 will attempt to retrieve the name of the sequence from the database
134 $table->add_column('col' => \%info?);
136 Convenience alias to add_columns.
141 my ($self, @cols) = @_;
142 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
145 my $columns = $self->_columns;
146 while (my $col = shift @cols) {
147 # If next entry is { ... } use that for the column info, if not
148 # use an empty hashref
149 my $column_info = ref $cols[0] ? shift(@cols) : {};
150 push(@added, $col) unless exists $columns->{$col};
151 $columns->{$col} = $column_info;
153 push @{ $self->_ordered_columns }, @added;
157 *add_column = \&add_columns;
161 if ($obj->has_column($col)) { ... }
163 Returns true if the source has a column of this name, false otherwise.
168 my ($self, $column) = @_;
169 return exists $self->_columns->{$column};
174 my $info = $obj->column_info($col);
176 Returns the column metadata hashref for a column. See the description
177 of add_column for information on the contents of the hashref.
182 my ($self, $column) = @_;
183 $self->throw_exception("No such column $column")
184 unless exists $self->_columns->{$column};
185 #warn $self->{_columns_info_loaded}, "\n";
186 if ( ! $self->_columns->{$column}{data_type}
187 and $self->column_info_from_storage
188 and ! $self->{_columns_info_loaded}
189 and $self->schema and $self->storage )
191 $self->{_columns_info_loaded}++;
194 # eval for the case of storage without table
195 eval { $info = $self->storage->columns_info_for( $self->from ) };
197 for my $realcol ( keys %{$info} ) {
198 $lc_info->{lc $realcol} = $info->{$realcol};
200 foreach my $col ( keys %{$self->_columns} ) {
201 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
205 return $self->_columns->{$column};
208 =head2 load_column_info_from_storage
210 Enables the on-demand automatic loading of the above column
211 metadata from storage as neccesary.
215 sub load_column_info_from_storage { shift->column_info_from_storage(1) }
219 my @column_names = $obj->columns;
221 Returns all column names in the order they were declared to add_columns.
227 $self->throw_exception(
228 "columns() is a read-only accessor, did you mean add_columns()?"
230 return @{$self->{_ordered_columns}||[]};
233 =head2 remove_columns
235 $table->remove_columns(qw/col1 col2 col3/);
237 Removes columns from the result source.
241 $table->remove_column('col');
243 Convenience alias to remove_columns.
248 my ($self, @cols) = @_;
250 return unless $self->_ordered_columns;
252 my $columns = $self->_columns;
255 foreach my $col (@{$self->_ordered_columns}) {
256 push @remaining, $col unless grep(/$col/, @cols);
260 undef $columns->{$_};
263 $self->_ordered_columns(\@remaining);
266 *remove_column = \&remove_columns;
268 =head2 set_primary_key
272 =item Arguments: @cols
276 Defines one or more columns as primary key for this source. Should be
277 called after C<add_columns>.
279 Additionally, defines a unique constraint named C<primary>.
281 The primary key columns are used by L<DBIx::Class::PK::Auto> to
282 retrieve automatically created values from the database.
286 sub set_primary_key {
287 my ($self, @cols) = @_;
288 # check if primary key columns are valid columns
289 foreach my $col (@cols) {
290 $self->throw_exception("No such column $col on table " . $self->name)
291 unless $self->has_column($col);
293 $self->_primaries(\@cols);
295 $self->add_unique_constraint(primary => \@cols);
298 =head2 primary_columns
300 Read-only accessor which returns the list of primary keys.
304 sub primary_columns {
305 return @{shift->_primaries||[]};
308 =head2 add_unique_constraint
310 Declare a unique constraint on this source. Call once for each unique
313 # For UNIQUE (column1, column2)
314 __PACKAGE__->add_unique_constraint(
315 constraint_name => [ qw/column1 column2/ ],
318 Alternatively, you can specify only the columns:
320 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
322 This will result in a unique constraint named C<table_column1_column2>, where
323 C<table> is replaced with the table name.
325 Unique constraints are used, for example, when you call
326 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
330 sub add_unique_constraint {
335 $name ||= $self->name_unique_constraint($cols);
337 foreach my $col (@$cols) {
338 $self->throw_exception("No such column $col on table " . $self->name)
339 unless $self->has_column($col);
342 my %unique_constraints = $self->unique_constraints;
343 $unique_constraints{$name} = $cols;
344 $self->_unique_constraints(\%unique_constraints);
347 =head2 name_unique_constraint
349 Return a name for a unique constraint containing the specified columns. These
350 names consist of the table name and each column name, separated by underscores.
352 For example, a constraint on a table named C<cd> containing the columns
353 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
357 sub name_unique_constraint {
358 my ($self, $cols) = @_;
360 return join '_', $self->name, @$cols;
363 =head2 unique_constraints
365 Read-only accessor which returns the list of unique constraints on this source.
369 sub unique_constraints {
370 return %{shift->_unique_constraints||{}};
373 =head2 unique_constraint_names
375 Returns the list of unique constraint names defined on this source.
379 sub unique_constraint_names {
382 my %unique_constraints = $self->unique_constraints;
384 return keys %unique_constraints;
387 =head2 unique_constraint_columns
389 Returns the list of columns that make up the specified unique constraint.
393 sub unique_constraint_columns {
394 my ($self, $constraint_name) = @_;
396 my %unique_constraints = $self->unique_constraints;
398 $self->throw_exception(
399 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
400 ) unless exists $unique_constraints{$constraint_name};
402 return @{ $unique_constraints{$constraint_name} };
407 Returns an expression of the source to be supplied to storage to specify
408 retrieval from this source. In the case of a database, the required FROM
413 Returns the L<DBIx::Class::Schema> object that this result source
418 Returns the storage handle for the current schema.
420 See also: L<DBIx::Class::Storage>
424 sub storage { shift->schema->storage; }
426 =head2 add_relationship
428 $source->add_relationship('relname', 'related_source', $cond, $attrs);
430 The relationship name can be arbitrary, but must be unique for each
431 relationship attached to this result source. 'related_source' should
432 be the name with which the related result source was registered with
433 the current schema. For example:
435 $schema->source('Book')->add_relationship('reviews', 'Review', {
436 'foreign.book_id' => 'self.id',
439 The condition C<$cond> needs to be an L<SQL::Abstract>-style
440 representation of the join between the tables. For example, if you're
441 creating a rel from Author to Book,
443 { 'foreign.author_id' => 'self.id' }
445 will result in the JOIN clause
447 author me JOIN book foreign ON foreign.author_id = me.id
449 You can specify as many foreign => self mappings as necessary.
451 Valid attributes are as follows:
457 Explicitly specifies the type of join to use in the relationship. Any
458 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
459 the SQL command immediately before C<JOIN>.
463 An arrayref containing a list of accessors in the foreign class to proxy in
464 the main class. If, for example, you do the following:
466 CD->might_have(liner_notes => 'LinerNotes', undef, {
467 proxy => [ qw/notes/ ],
470 Then, assuming LinerNotes has an accessor named notes, you can do:
472 my $cd = CD->find(1);
473 # set notes -- LinerNotes object is created if it doesn't exist
474 $cd->notes('Notes go here');
478 Specifies the type of accessor that should be created for the
479 relationship. Valid values are C<single> (for when there is only a single
480 related object), C<multi> (when there can be many), and C<filter> (for
481 when there is a single related object, but you also want the relationship
482 accessor to double as a column accessor). For C<multi> accessors, an
483 add_to_* method is also created, which calls C<create_related> for the
490 sub add_relationship {
491 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
492 $self->throw_exception("Can't create relationship without join condition")
496 my %rels = %{ $self->_relationships };
497 $rels{$rel} = { class => $f_source_name,
498 source => $f_source_name,
501 $self->_relationships(\%rels);
505 # XXX disabled. doesn't work properly currently. skip in tests.
507 my $f_source = $self->schema->source($f_source_name);
509 $self->ensure_class_loaded($f_source_name);
510 $f_source = $f_source_name->result_source;
511 #my $s_class = ref($self->schema);
512 #$f_source_name =~ m/^${s_class}::(.*)$/;
513 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
514 #$f_source = $self->schema->source($f_source_name);
516 return unless $f_source; # Can't test rel without f_source
518 eval { $self->resolve_join($rel, 'me') };
520 if ($@) { # If the resolve failed, back out and re-throw the error
521 delete $rels{$rel}; #
522 $self->_relationships(\%rels);
523 $self->throw_exception("Error creating relationship $rel: $@");
530 Returns all relationship names for this source.
535 return keys %{shift->_relationships};
538 =head2 relationship_info
542 =item Arguments: $relname
546 Returns a hash of relationship information for the specified relationship
551 sub relationship_info {
552 my ($self, $rel) = @_;
553 return $self->_relationships->{$rel};
556 =head2 has_relationship
560 =item Arguments: $rel
564 Returns true if the source has a relationship of this name, false otherwise.
568 sub has_relationship {
569 my ($self, $rel) = @_;
570 return exists $self->_relationships->{$rel};
573 =head2 reverse_relationship_info
577 =item Arguments: $relname
581 Returns an array of hash references of relationship information for
582 the other side of the specified relationship name.
586 sub reverse_relationship_info {
587 my ($self, $rel) = @_;
588 my $rel_info = $self->relationship_info($rel);
591 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
593 my @cond = keys(%{$rel_info->{cond}});
594 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
595 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
597 # Get the related result source for this relationship
598 my $othertable = $self->related_source($rel);
600 # Get all the relationships for that source that related to this source
601 # whose foreign column set are our self columns on $rel and whose self
602 # columns are our foreign columns on $rel.
603 my @otherrels = $othertable->relationships();
604 my $otherrelationship;
605 foreach my $otherrel (@otherrels) {
606 my $otherrel_info = $othertable->relationship_info($otherrel);
608 my $back = $othertable->related_source($otherrel);
609 next unless $back->name eq $self->name;
613 if (ref $otherrel_info->{cond} eq 'HASH') {
614 @othertestconds = ($otherrel_info->{cond});
616 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
617 @othertestconds = @{$otherrel_info->{cond}};
623 foreach my $othercond (@othertestconds) {
624 my @other_cond = keys(%$othercond);
625 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
626 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
627 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
628 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
629 $ret->{$otherrel} = $otherrel_info;
635 =head2 compare_relationship_keys
639 =item Arguments: $keys1, $keys2
643 Returns true if both sets of keynames are the same, false otherwise.
647 sub compare_relationship_keys {
648 my ($self, $keys1, $keys2) = @_;
650 # Make sure every keys1 is in keys2
652 foreach my $key (@$keys1) {
654 foreach my $prim (@$keys2) {
663 # Make sure every key2 is in key1
665 foreach my $prim (@$keys2) {
667 foreach my $key (@$keys1) {
684 =item Arguments: $relation
688 Returns the join structure required for the related result source.
693 my ($self, $join, $alias, $seen) = @_;
695 if (ref $join eq 'ARRAY') {
696 return map { $self->resolve_join($_, $alias, $seen) } @$join;
697 } elsif (ref $join eq 'HASH') {
700 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
701 ($self->resolve_join($_, $alias, $seen),
702 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
704 } elsif (ref $join) {
705 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
707 my $count = ++$seen->{$join};
708 #use Data::Dumper; warn Dumper($seen);
709 my $as = ($count > 1 ? "${join}_${count}" : $join);
710 my $rel_info = $self->relationship_info($join);
711 $self->throw_exception("No such relationship ${join}") unless $rel_info;
712 my $type = $rel_info->{attrs}{join_type} || '';
713 return [ { $as => $self->related_source($join)->from,
714 -join_type => $type },
715 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
719 =head2 resolve_condition
723 =item Arguments: $cond, $as, $alias|$object
727 Resolves the passed condition to a concrete query fragment. If given an alias,
728 returns a join condition; if given an object, inverts that object to produce
729 a related conditional from that object.
733 sub resolve_condition {
734 my ($self, $cond, $as, $for) = @_;
736 if (ref $cond eq 'HASH') {
738 foreach my $k (keys %{$cond}) {
740 # XXX should probably check these are valid columns
741 $k =~ s/^foreign\.// ||
742 $self->throw_exception("Invalid rel cond key ${k}");
744 $self->throw_exception("Invalid rel cond val ${v}");
745 if (ref $for) { # Object
746 #warn "$self $k $for $v";
747 $ret{$k} = $for->get_column($v);
749 } elsif (!defined $for) { # undef, i.e. "no object"
751 } elsif (ref $as) { # reverse object
752 $ret{$v} = $as->get_column($k);
753 } elsif (!defined $as) { # undef, i.e. "no reverse object"
756 $ret{"${as}.${k}"} = "${for}.${v}";
760 } elsif (ref $cond eq 'ARRAY') {
761 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
763 die("Can't handle this yet :(");
767 =head2 resolve_prefetch
771 =item Arguments: hashref/arrayref/scalar
775 Accepts one or more relationships for the current source and returns an
776 array of column names for each of those relationships. Column names are
777 prefixed relative to the current source, in accordance with where they appear
778 in the supplied relationships. Examples:
780 my $source = $schema->resultset('Tag')->source;
781 @columns = $source->resolve_prefetch( { cd => 'artist' } );
789 # 'cd.artist.artistid',
793 @columns = $source->resolve_prefetch( qw[/ cd /] );
803 $source = $schema->resultset('CD')->source;
804 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
810 # 'producer.producerid',
816 sub resolve_prefetch {
817 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
819 #$alias ||= $self->name;
820 #warn $alias, Dumper $pre;
821 if( ref $pre eq 'ARRAY' ) {
823 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
826 elsif( ref $pre eq 'HASH' ) {
829 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
830 $self->related_source($_)->resolve_prefetch(
831 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
837 $self->throw_exception(
838 "don't know how to resolve prefetch reftype ".ref($pre));
841 my $count = ++$seen->{$pre};
842 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
843 my $rel_info = $self->relationship_info( $pre );
844 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
846 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
847 my $rel_source = $self->related_source($pre);
849 if (exists $rel_info->{attrs}{accessor}
850 && $rel_info->{attrs}{accessor} eq 'multi') {
851 $self->throw_exception(
852 "Can't prefetch has_many ${pre} (join cond too complex)")
853 unless ref($rel_info->{cond}) eq 'HASH';
854 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
855 keys %{$rel_info->{cond}};
856 $collapse->{"${as_prefix}${pre}"} = \@key;
857 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
858 ? @{$rel_info->{attrs}{order_by}}
859 : (defined $rel_info->{attrs}{order_by}
860 ? ($rel_info->{attrs}{order_by})
862 push(@$order, map { "${as}.$_" } (@key, @ord));
865 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
866 $rel_source->columns;
867 #warn $alias, Dumper (\@ret);
872 =head2 related_source
876 =item Arguments: $relname
880 Returns the result source object for the given relationship.
885 my ($self, $rel) = @_;
886 if( !$self->has_relationship( $rel ) ) {
887 $self->throw_exception("No such relationship '$rel'");
889 return $self->schema->source($self->relationship_info($rel)->{source});
896 =item Arguments: $relname
900 Returns the class name for objects in the given relationship.
905 my ($self, $rel) = @_;
906 if( !$self->has_relationship( $rel ) ) {
907 $self->throw_exception("No such relationship '$rel'");
909 return $self->schema->class($self->relationship_info($rel)->{source});
914 Returns a resultset for the given source. This will initially be created
917 $self->resultset_class->new($self, $self->resultset_attributes)
919 but is cached from then on unless resultset_class changes.
921 =head2 resultset_class
923 Set the class of the resultset, this is useful if you want to create your
924 own resultset methods. Create your own class derived from
925 L<DBIx::Class::ResultSet>, and set it here.
927 =head2 resultset_attributes
929 Specify here any attributes you wish to pass to your specialised resultset.
935 $self->throw_exception(
936 'resultset does not take any arguments. If you want another resultset, '.
937 'call it on the schema instead.'
940 # disabled until we can figure out a way to do it without consistency issues
942 #return $self->{_resultset}
943 # if ref $self->{_resultset} eq $self->resultset_class;
944 #return $self->{_resultset} =
946 return $self->resultset_class->new(
947 $self, $self->{resultset_attributes}
955 =item Arguments: $source_name
959 Set the name of the result source when it is loaded into a schema.
960 This is usefull if you want to refer to a result source by a name other than
963 package ArchivedBooks;
964 use base qw/DBIx::Class/;
965 __PACKAGE__->table('books_archive');
966 __PACKAGE__->source_name('Books');
968 # from your schema...
969 $schema->resultset('Books')->find(1);
971 =head2 throw_exception
973 See L<DBIx::Class::Schema/"throw_exception">.
977 sub throw_exception {
979 if (defined $self->schema) {
980 $self->schema->throw_exception(@_);
988 Matt S. Trout <mst@shadowcatsystems.co.uk>
992 You may distribute this code under the same terms as Perl itself.