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;
59 if(!defined $new->column_info_from_storage) {
60 $new->{column_info_from_storage} = 1
69 $table->add_columns(qw/col1 col2 col3/);
71 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
73 Adds columns to the result source. If supplied key => hashref pairs, uses
74 the hashref as the column_info for that column. Repeated calls of this
75 method will add more columns, not replace them.
77 The contents of the column_info are not set in stone. The following
78 keys are currently recognised/used by DBIx::Class:
84 Use this to set the name of the accessor for this column. If unset,
85 the name of the column will be used.
89 This contains the column type. It is automatically filled by the
90 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
91 L<DBIx::Class::Schema::Loader> module. If you do not enter a
92 data_type, DBIx::Class will attempt to retrieve it from the
93 database for you, using L<DBI>'s column_info method. The values of this
94 key are typically upper-cased.
96 Currently there is no standard set of values for the data_type. Use
97 whatever your database supports.
101 The length of your column, if it is a column type that can have a size
102 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
106 Set this to a true value for a columns that is allowed to contain
107 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
109 =item is_auto_increment
111 Set this to a true value for a column whose value is somehow
112 automatically set. This is used to determine which columns to empty
113 when cloning objects using C<copy>. It is also used by
114 L<DBIx::Class::Schema/deploy>.
118 Set this to a true value for a column that contains a key from a
119 foreign table. This is currently only used by
120 L<DBIx::Class::Schema/deploy>.
124 Set this to the default value which will be inserted into a column
125 by the database. Can contain either a value or a function. This is
126 currently only used by L<DBIx::Class::Schema/deploy>.
130 Set this on a primary key column to the name of the sequence used to
131 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
132 will attempt to retrieve the name of the sequence from the database
137 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
138 to add extra non-generic data to the column. For example: C<< extras
139 => { unsigned => 1} >> is used by the MySQL producer to set an integer
140 column to unsigned. For more details, see
141 L<SQL::Translator::Producer::MySQL>.
147 $table->add_column('col' => \%info?);
149 Convenience alias to add_columns.
154 my ($self, @cols) = @_;
155 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
158 my $columns = $self->_columns;
159 while (my $col = shift @cols) {
160 # If next entry is { ... } use that for the column info, if not
161 # use an empty hashref
162 my $column_info = ref $cols[0] ? shift(@cols) : {};
163 push(@added, $col) unless exists $columns->{$col};
164 $columns->{$col} = $column_info;
166 push @{ $self->_ordered_columns }, @added;
170 *add_column = \&add_columns;
174 if ($obj->has_column($col)) { ... }
176 Returns true if the source has a column of this name, false otherwise.
181 my ($self, $column) = @_;
182 return exists $self->_columns->{$column};
187 my $info = $obj->column_info($col);
189 Returns the column metadata hashref for a column. See the description
190 of add_column for information on the contents of the hashref.
195 my ($self, $column) = @_;
196 $self->throw_exception("No such column $column")
197 unless exists $self->_columns->{$column};
198 #warn $self->{_columns_info_loaded}, "\n";
199 if ( ! $self->_columns->{$column}{data_type}
200 and $self->column_info_from_storage
201 and ! $self->{_columns_info_loaded}
202 and $self->schema and $self->storage )
204 $self->{_columns_info_loaded}++;
207 # eval for the case of storage without table
208 eval { $info = $self->storage->columns_info_for( $self->from ) };
210 for my $realcol ( keys %{$info} ) {
211 $lc_info->{lc $realcol} = $info->{$realcol};
213 foreach my $col ( keys %{$self->_columns} ) {
214 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
218 return $self->_columns->{$column};
221 =head2 column_info_from_storage
223 Enables or disables the on-demand automatic loading of the above
224 column metadata from storage as neccesary. Defaults to true in the
225 current release, but will default to false in future releases starting
226 with 0.08000. This is *deprecated*, and should not be used. It will
227 be removed before 1.0.
229 __PACKAGE__->column_info_from_storage(0);
230 __PACKAGE__->column_info_from_storage(1);
234 my @column_names = $obj->columns;
236 Returns all column names in the order they were declared to add_columns.
242 $self->throw_exception(
243 "columns() is a read-only accessor, did you mean add_columns()?"
245 return @{$self->{_ordered_columns}||[]};
248 =head2 remove_columns
250 $table->remove_columns(qw/col1 col2 col3/);
252 Removes columns from the result source.
256 $table->remove_column('col');
258 Convenience alias to remove_columns.
263 my ($self, @cols) = @_;
265 return unless $self->_ordered_columns;
267 my $columns = $self->_columns;
270 foreach my $col (@{$self->_ordered_columns}) {
271 push @remaining, $col unless grep(/$col/, @cols);
275 delete $columns->{$_};
278 $self->_ordered_columns(\@remaining);
281 *remove_column = \&remove_columns;
283 =head2 set_primary_key
287 =item Arguments: @cols
291 Defines one or more columns as primary key for this source. Should be
292 called after C<add_columns>.
294 Additionally, defines a unique constraint named C<primary>.
296 The primary key columns are used by L<DBIx::Class::PK::Auto> to
297 retrieve automatically created values from the database.
301 sub set_primary_key {
302 my ($self, @cols) = @_;
303 # check if primary key columns are valid columns
304 foreach my $col (@cols) {
305 $self->throw_exception("No such column $col on table " . $self->name)
306 unless $self->has_column($col);
308 $self->_primaries(\@cols);
310 $self->add_unique_constraint(primary => \@cols);
313 =head2 primary_columns
315 Read-only accessor which returns the list of primary keys.
319 sub primary_columns {
320 return @{shift->_primaries||[]};
323 =head2 add_unique_constraint
325 Declare a unique constraint on this source. Call once for each unique
328 # For UNIQUE (column1, column2)
329 __PACKAGE__->add_unique_constraint(
330 constraint_name => [ qw/column1 column2/ ],
333 Alternatively, you can specify only the columns:
335 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
337 This will result in a unique constraint named C<table_column1_column2>, where
338 C<table> is replaced with the table name.
340 Unique constraints are used, for example, when you call
341 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
345 sub add_unique_constraint {
350 $name ||= $self->name_unique_constraint($cols);
352 foreach my $col (@$cols) {
353 $self->throw_exception("No such column $col on table " . $self->name)
354 unless $self->has_column($col);
357 my %unique_constraints = $self->unique_constraints;
358 $unique_constraints{$name} = $cols;
359 $self->_unique_constraints(\%unique_constraints);
362 =head2 name_unique_constraint
364 Return a name for a unique constraint containing the specified columns. These
365 names consist of the table name and each column name, separated by underscores.
367 For example, a constraint on a table named C<cd> containing the columns
368 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
372 sub name_unique_constraint {
373 my ($self, $cols) = @_;
375 return join '_', $self->name, @$cols;
378 =head2 unique_constraints
380 Read-only accessor which returns the list of unique constraints on this source.
384 sub unique_constraints {
385 return %{shift->_unique_constraints||{}};
388 =head2 unique_constraint_names
390 Returns the list of unique constraint names defined on this source.
394 sub unique_constraint_names {
397 my %unique_constraints = $self->unique_constraints;
399 return keys %unique_constraints;
402 =head2 unique_constraint_columns
404 Returns the list of columns that make up the specified unique constraint.
408 sub unique_constraint_columns {
409 my ($self, $constraint_name) = @_;
411 my %unique_constraints = $self->unique_constraints;
413 $self->throw_exception(
414 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
415 ) unless exists $unique_constraints{$constraint_name};
417 return @{ $unique_constraints{$constraint_name} };
422 Returns an expression of the source to be supplied to storage to specify
423 retrieval from this source. In the case of a database, the required FROM
428 Returns the L<DBIx::Class::Schema> object that this result source
433 Returns the storage handle for the current schema.
435 See also: L<DBIx::Class::Storage>
439 sub storage { shift->schema->storage; }
441 =head2 add_relationship
443 $source->add_relationship('relname', 'related_source', $cond, $attrs);
445 The relationship name can be arbitrary, but must be unique for each
446 relationship attached to this result source. 'related_source' should
447 be the name with which the related result source was registered with
448 the current schema. For example:
450 $schema->source('Book')->add_relationship('reviews', 'Review', {
451 'foreign.book_id' => 'self.id',
454 The condition C<$cond> needs to be an L<SQL::Abstract>-style
455 representation of the join between the tables. For example, if you're
456 creating a rel from Author to Book,
458 { 'foreign.author_id' => 'self.id' }
460 will result in the JOIN clause
462 author me JOIN book foreign ON foreign.author_id = me.id
464 You can specify as many foreign => self mappings as necessary.
466 Valid attributes are as follows:
472 Explicitly specifies the type of join to use in the relationship. Any
473 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
474 the SQL command immediately before C<JOIN>.
478 An arrayref containing a list of accessors in the foreign class to proxy in
479 the main class. If, for example, you do the following:
481 CD->might_have(liner_notes => 'LinerNotes', undef, {
482 proxy => [ qw/notes/ ],
485 Then, assuming LinerNotes has an accessor named notes, you can do:
487 my $cd = CD->find(1);
488 # set notes -- LinerNotes object is created if it doesn't exist
489 $cd->notes('Notes go here');
493 Specifies the type of accessor that should be created for the
494 relationship. Valid values are C<single> (for when there is only a single
495 related object), C<multi> (when there can be many), and C<filter> (for
496 when there is a single related object, but you also want the relationship
497 accessor to double as a column accessor). For C<multi> accessors, an
498 add_to_* method is also created, which calls C<create_related> for the
505 sub add_relationship {
506 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
507 $self->throw_exception("Can't create relationship without join condition")
511 my %rels = %{ $self->_relationships };
512 $rels{$rel} = { class => $f_source_name,
513 source => $f_source_name,
516 $self->_relationships(\%rels);
520 # XXX disabled. doesn't work properly currently. skip in tests.
522 my $f_source = $self->schema->source($f_source_name);
524 $self->ensure_class_loaded($f_source_name);
525 $f_source = $f_source_name->result_source;
526 #my $s_class = ref($self->schema);
527 #$f_source_name =~ m/^${s_class}::(.*)$/;
528 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
529 #$f_source = $self->schema->source($f_source_name);
531 return unless $f_source; # Can't test rel without f_source
533 eval { $self->resolve_join($rel, 'me') };
535 if ($@) { # If the resolve failed, back out and re-throw the error
536 delete $rels{$rel}; #
537 $self->_relationships(\%rels);
538 $self->throw_exception("Error creating relationship $rel: $@");
545 Returns all relationship names for this source.
550 return keys %{shift->_relationships};
553 =head2 relationship_info
557 =item Arguments: $relname
561 Returns a hash of relationship information for the specified relationship
566 sub relationship_info {
567 my ($self, $rel) = @_;
568 return $self->_relationships->{$rel};
571 =head2 has_relationship
575 =item Arguments: $rel
579 Returns true if the source has a relationship of this name, false otherwise.
583 sub has_relationship {
584 my ($self, $rel) = @_;
585 return exists $self->_relationships->{$rel};
588 =head2 reverse_relationship_info
592 =item Arguments: $relname
596 Returns an array of hash references of relationship information for
597 the other side of the specified relationship name.
601 sub reverse_relationship_info {
602 my ($self, $rel) = @_;
603 my $rel_info = $self->relationship_info($rel);
606 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
608 my @cond = keys(%{$rel_info->{cond}});
609 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
610 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
612 # Get the related result source for this relationship
613 my $othertable = $self->related_source($rel);
615 # Get all the relationships for that source that related to this source
616 # whose foreign column set are our self columns on $rel and whose self
617 # columns are our foreign columns on $rel.
618 my @otherrels = $othertable->relationships();
619 my $otherrelationship;
620 foreach my $otherrel (@otherrels) {
621 my $otherrel_info = $othertable->relationship_info($otherrel);
623 my $back = $othertable->related_source($otherrel);
624 next unless $back->name eq $self->name;
628 if (ref $otherrel_info->{cond} eq 'HASH') {
629 @othertestconds = ($otherrel_info->{cond});
631 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
632 @othertestconds = @{$otherrel_info->{cond}};
638 foreach my $othercond (@othertestconds) {
639 my @other_cond = keys(%$othercond);
640 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
641 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
642 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
643 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
644 $ret->{$otherrel} = $otherrel_info;
650 =head2 compare_relationship_keys
654 =item Arguments: $keys1, $keys2
658 Returns true if both sets of keynames are the same, false otherwise.
662 sub compare_relationship_keys {
663 my ($self, $keys1, $keys2) = @_;
665 # Make sure every keys1 is in keys2
667 foreach my $key (@$keys1) {
669 foreach my $prim (@$keys2) {
678 # Make sure every key2 is in key1
680 foreach my $prim (@$keys2) {
682 foreach my $key (@$keys1) {
699 =item Arguments: $relation
703 Returns the join structure required for the related result source.
708 my ($self, $join, $alias, $seen) = @_;
710 if (ref $join eq 'ARRAY') {
711 return map { $self->resolve_join($_, $alias, $seen) } @$join;
712 } elsif (ref $join eq 'HASH') {
715 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
716 ($self->resolve_join($_, $alias, $seen),
717 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
719 } elsif (ref $join) {
720 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
722 my $count = ++$seen->{$join};
723 #use Data::Dumper; warn Dumper($seen);
724 my $as = ($count > 1 ? "${join}_${count}" : $join);
725 my $rel_info = $self->relationship_info($join);
726 $self->throw_exception("No such relationship ${join}") unless $rel_info;
727 my $type = $rel_info->{attrs}{join_type} || '';
728 return [ { $as => $self->related_source($join)->from,
729 -join_type => $type },
730 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
734 =head2 resolve_condition
738 =item Arguments: $cond, $as, $alias|$object
742 Resolves the passed condition to a concrete query fragment. If given an alias,
743 returns a join condition; if given an object, inverts that object to produce
744 a related conditional from that object.
748 sub resolve_condition {
749 my ($self, $cond, $as, $for) = @_;
751 if (ref $cond eq 'HASH') {
753 foreach my $k (keys %{$cond}) {
755 # XXX should probably check these are valid columns
756 $k =~ s/^foreign\.// ||
757 $self->throw_exception("Invalid rel cond key ${k}");
759 $self->throw_exception("Invalid rel cond val ${v}");
760 if (ref $for) { # Object
761 #warn "$self $k $for $v";
762 $ret{$k} = $for->get_column($v);
764 } elsif (!defined $for) { # undef, i.e. "no object"
766 } elsif (ref $as) { # reverse object
767 $ret{$v} = $as->get_column($k);
768 } elsif (!defined $as) { # undef, i.e. "no reverse object"
771 $ret{"${as}.${k}"} = "${for}.${v}";
775 } elsif (ref $cond eq 'ARRAY') {
776 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
778 die("Can't handle this yet :(");
782 =head2 resolve_prefetch
786 =item Arguments: hashref/arrayref/scalar
790 Accepts one or more relationships for the current source and returns an
791 array of column names for each of those relationships. Column names are
792 prefixed relative to the current source, in accordance with where they appear
793 in the supplied relationships. Examples:
795 my $source = $schema->resultset('Tag')->source;
796 @columns = $source->resolve_prefetch( { cd => 'artist' } );
804 # 'cd.artist.artistid',
808 @columns = $source->resolve_prefetch( qw[/ cd /] );
818 $source = $schema->resultset('CD')->source;
819 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
825 # 'producer.producerid',
831 sub resolve_prefetch {
832 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
834 #$alias ||= $self->name;
835 #warn $alias, Dumper $pre;
836 if( ref $pre eq 'ARRAY' ) {
838 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
841 elsif( ref $pre eq 'HASH' ) {
844 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
845 $self->related_source($_)->resolve_prefetch(
846 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
852 $self->throw_exception(
853 "don't know how to resolve prefetch reftype ".ref($pre));
856 my $count = ++$seen->{$pre};
857 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
858 my $rel_info = $self->relationship_info( $pre );
859 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
861 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
862 my $rel_source = $self->related_source($pre);
864 if (exists $rel_info->{attrs}{accessor}
865 && $rel_info->{attrs}{accessor} eq 'multi') {
866 $self->throw_exception(
867 "Can't prefetch has_many ${pre} (join cond too complex)")
868 unless ref($rel_info->{cond}) eq 'HASH';
869 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
870 keys %{$rel_info->{cond}};
871 $collapse->{"${as_prefix}${pre}"} = \@key;
872 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
873 ? @{$rel_info->{attrs}{order_by}}
874 : (defined $rel_info->{attrs}{order_by}
875 ? ($rel_info->{attrs}{order_by})
877 push(@$order, map { "${as}.$_" } (@key, @ord));
880 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
881 $rel_source->columns;
882 #warn $alias, Dumper (\@ret);
887 =head2 related_source
891 =item Arguments: $relname
895 Returns the result source object for the given relationship.
900 my ($self, $rel) = @_;
901 if( !$self->has_relationship( $rel ) ) {
902 $self->throw_exception("No such relationship '$rel'");
904 return $self->schema->source($self->relationship_info($rel)->{source});
911 =item Arguments: $relname
915 Returns the class name for objects in the given relationship.
920 my ($self, $rel) = @_;
921 if( !$self->has_relationship( $rel ) ) {
922 $self->throw_exception("No such relationship '$rel'");
924 return $self->schema->class($self->relationship_info($rel)->{source});
929 Returns a resultset for the given source. This will initially be created
932 $self->resultset_class->new($self, $self->resultset_attributes)
934 but is cached from then on unless resultset_class changes.
936 =head2 resultset_class
938 ` package My::ResultSetClass;
939 use base 'DBIx::Class::ResultSet';
942 $source->resultset_class('My::ResultSet::Class');
944 Set the class of the resultset, this is useful if you want to create your
945 own resultset methods. Create your own class derived from
946 L<DBIx::Class::ResultSet>, and set it here.
948 =head2 resultset_attributes
950 $source->resultset_attributes({ order_by => [ 'id' ] });
952 Specify here any attributes you wish to pass to your specialised resultset.
958 $self->throw_exception(
959 'resultset does not take any arguments. If you want another resultset, '.
960 'call it on the schema instead.'
963 # disabled until we can figure out a way to do it without consistency issues
965 #return $self->{_resultset}
966 # if ref $self->{_resultset} eq $self->resultset_class;
967 #return $self->{_resultset} =
969 return $self->resultset_class->new(
970 $self, $self->{resultset_attributes}
978 =item Arguments: $source_name
982 Set the name of the result source when it is loaded into a schema.
983 This is usefull if you want to refer to a result source by a name other than
986 package ArchivedBooks;
987 use base qw/DBIx::Class/;
988 __PACKAGE__->table('books_archive');
989 __PACKAGE__->source_name('Books');
991 # from your schema...
992 $schema->resultset('Books')->find(1);
994 =head2 throw_exception
996 See L<DBIx::Class::Schema/"throw_exception">.
1000 sub throw_exception {
1002 if (defined $self->schema) {
1003 $self->schema->throw_exception(@_);
1011 Matt S. Trout <mst@shadowcatsystems.co.uk>
1015 You may distribute this code under the same terms as Perl itself.