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 not used by DBIx::Class.
106 Set this to a true value for a columns that is allowed to contain
107 NULL values. This is currently not used by DBIx::Class.
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>.
117 Set this to a true value for a column that contains a key from a
118 foreign table. This is currently not used by DBIx::Class.
122 Set this to the default value which will be inserted into a column
123 by the database. Can contain either a value or a function. This is
124 currently not used by DBIx::Class.
128 Set this on a primary key column to the name of the sequence used to
129 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
130 will attempt to retrieve the name of the sequence from the database
137 $table->add_column('col' => \%info?);
139 Convenience alias to add_columns.
144 my ($self, @cols) = @_;
145 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
148 my $columns = $self->_columns;
149 while (my $col = shift @cols) {
150 # If next entry is { ... } use that for the column info, if not
151 # use an empty hashref
152 my $column_info = ref $cols[0] ? shift(@cols) : {};
153 push(@added, $col) unless exists $columns->{$col};
154 $columns->{$col} = $column_info;
156 push @{ $self->_ordered_columns }, @added;
160 *add_column = \&add_columns;
164 if ($obj->has_column($col)) { ... }
166 Returns true if the source has a column of this name, false otherwise.
171 my ($self, $column) = @_;
172 return exists $self->_columns->{$column};
177 my $info = $obj->column_info($col);
179 Returns the column metadata hashref for a column. See the description
180 of add_column for information on the contents of the hashref.
185 my ($self, $column) = @_;
186 $self->throw_exception("No such column $column")
187 unless exists $self->_columns->{$column};
188 #warn $self->{_columns_info_loaded}, "\n";
189 if ( ! $self->_columns->{$column}{data_type}
190 and $self->column_info_from_storage
191 and ! $self->{_columns_info_loaded}
192 and $self->schema and $self->storage )
194 $self->{_columns_info_loaded}++;
197 # eval for the case of storage without table
198 eval { $info = $self->storage->columns_info_for( $self->from ) };
200 for my $realcol ( keys %{$info} ) {
201 $lc_info->{lc $realcol} = $info->{$realcol};
203 foreach my $col ( keys %{$self->_columns} ) {
204 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
208 return $self->_columns->{$column};
211 =head2 column_info_from_storage
213 Enables or disables the on-demand automatic loading of the above
214 column metadata from storage as neccesary. Defaults to true in the
215 current release, but will default to false in future releases starting
216 with 0.08000. This is *deprecated*, and should not be used. It will
217 be removed before 1.0.
219 __PACKAGE__->column_info_from_storage(0);
220 __PACKAGE__->column_info_from_storage(1);
224 my @column_names = $obj->columns;
226 Returns all column names in the order they were declared to add_columns.
232 $self->throw_exception(
233 "columns() is a read-only accessor, did you mean add_columns()?"
235 return @{$self->{_ordered_columns}||[]};
238 =head2 remove_columns
240 $table->remove_columns(qw/col1 col2 col3/);
242 Removes columns from the result source.
246 $table->remove_column('col');
248 Convenience alias to remove_columns.
253 my ($self, @cols) = @_;
255 return unless $self->_ordered_columns;
257 my $columns = $self->_columns;
260 foreach my $col (@{$self->_ordered_columns}) {
261 push @remaining, $col unless grep(/$col/, @cols);
265 delete $columns->{$_};
268 $self->_ordered_columns(\@remaining);
271 *remove_column = \&remove_columns;
273 =head2 set_primary_key
277 =item Arguments: @cols
281 Defines one or more columns as primary key for this source. Should be
282 called after C<add_columns>.
284 Additionally, defines a unique constraint named C<primary>.
286 The primary key columns are used by L<DBIx::Class::PK::Auto> to
287 retrieve automatically created values from the database.
291 sub set_primary_key {
292 my ($self, @cols) = @_;
293 # check if primary key columns are valid columns
294 foreach my $col (@cols) {
295 $self->throw_exception("No such column $col on table " . $self->name)
296 unless $self->has_column($col);
298 $self->_primaries(\@cols);
300 $self->add_unique_constraint(primary => \@cols);
303 =head2 primary_columns
305 Read-only accessor which returns the list of primary keys.
309 sub primary_columns {
310 return @{shift->_primaries||[]};
313 =head2 add_unique_constraint
315 Declare a unique constraint on this source. Call once for each unique
318 # For UNIQUE (column1, column2)
319 __PACKAGE__->add_unique_constraint(
320 constraint_name => [ qw/column1 column2/ ],
323 Alternatively, you can specify only the columns:
325 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
327 This will result in a unique constraint named C<table_column1_column2>, where
328 C<table> is replaced with the table name.
330 Unique constraints are used, for example, when you call
331 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
335 sub add_unique_constraint {
340 $name ||= $self->name_unique_constraint($cols);
342 foreach my $col (@$cols) {
343 $self->throw_exception("No such column $col on table " . $self->name)
344 unless $self->has_column($col);
347 my %unique_constraints = $self->unique_constraints;
348 $unique_constraints{$name} = $cols;
349 $self->_unique_constraints(\%unique_constraints);
352 =head2 name_unique_constraint
354 Return a name for a unique constraint containing the specified columns. These
355 names consist of the table name and each column name, separated by underscores.
357 For example, a constraint on a table named C<cd> containing the columns
358 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
362 sub name_unique_constraint {
363 my ($self, $cols) = @_;
365 return join '_', $self->name, @$cols;
368 =head2 unique_constraints
370 Read-only accessor which returns the list of unique constraints on this source.
374 sub unique_constraints {
375 return %{shift->_unique_constraints||{}};
378 =head2 unique_constraint_names
380 Returns the list of unique constraint names defined on this source.
384 sub unique_constraint_names {
387 my %unique_constraints = $self->unique_constraints;
389 return keys %unique_constraints;
392 =head2 unique_constraint_columns
394 Returns the list of columns that make up the specified unique constraint.
398 sub unique_constraint_columns {
399 my ($self, $constraint_name) = @_;
401 my %unique_constraints = $self->unique_constraints;
403 $self->throw_exception(
404 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
405 ) unless exists $unique_constraints{$constraint_name};
407 return @{ $unique_constraints{$constraint_name} };
412 Returns an expression of the source to be supplied to storage to specify
413 retrieval from this source. In the case of a database, the required FROM
418 Returns the L<DBIx::Class::Schema> object that this result source
423 Returns the storage handle for the current schema.
425 See also: L<DBIx::Class::Storage>
429 sub storage { shift->schema->storage; }
431 =head2 add_relationship
433 $source->add_relationship('relname', 'related_source', $cond, $attrs);
435 The relationship name can be arbitrary, but must be unique for each
436 relationship attached to this result source. 'related_source' should
437 be the name with which the related result source was registered with
438 the current schema. For example:
440 $schema->source('Book')->add_relationship('reviews', 'Review', {
441 'foreign.book_id' => 'self.id',
444 The condition C<$cond> needs to be an L<SQL::Abstract>-style
445 representation of the join between the tables. For example, if you're
446 creating a rel from Author to Book,
448 { 'foreign.author_id' => 'self.id' }
450 will result in the JOIN clause
452 author me JOIN book foreign ON foreign.author_id = me.id
454 You can specify as many foreign => self mappings as necessary.
456 Valid attributes are as follows:
462 Explicitly specifies the type of join to use in the relationship. Any
463 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
464 the SQL command immediately before C<JOIN>.
468 An arrayref containing a list of accessors in the foreign class to proxy in
469 the main class. If, for example, you do the following:
471 CD->might_have(liner_notes => 'LinerNotes', undef, {
472 proxy => [ qw/notes/ ],
475 Then, assuming LinerNotes has an accessor named notes, you can do:
477 my $cd = CD->find(1);
478 # set notes -- LinerNotes object is created if it doesn't exist
479 $cd->notes('Notes go here');
483 Specifies the type of accessor that should be created for the
484 relationship. Valid values are C<single> (for when there is only a single
485 related object), C<multi> (when there can be many), and C<filter> (for
486 when there is a single related object, but you also want the relationship
487 accessor to double as a column accessor). For C<multi> accessors, an
488 add_to_* method is also created, which calls C<create_related> for the
495 sub add_relationship {
496 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
497 $self->throw_exception("Can't create relationship without join condition")
501 my %rels = %{ $self->_relationships };
502 $rels{$rel} = { class => $f_source_name,
503 source => $f_source_name,
506 $self->_relationships(\%rels);
510 # XXX disabled. doesn't work properly currently. skip in tests.
512 my $f_source = $self->schema->source($f_source_name);
514 $self->ensure_class_loaded($f_source_name);
515 $f_source = $f_source_name->result_source;
516 #my $s_class = ref($self->schema);
517 #$f_source_name =~ m/^${s_class}::(.*)$/;
518 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
519 #$f_source = $self->schema->source($f_source_name);
521 return unless $f_source; # Can't test rel without f_source
523 eval { $self->resolve_join($rel, 'me') };
525 if ($@) { # If the resolve failed, back out and re-throw the error
526 delete $rels{$rel}; #
527 $self->_relationships(\%rels);
528 $self->throw_exception("Error creating relationship $rel: $@");
535 Returns all relationship names for this source.
540 return keys %{shift->_relationships};
543 =head2 relationship_info
547 =item Arguments: $relname
551 Returns a hash of relationship information for the specified relationship
556 sub relationship_info {
557 my ($self, $rel) = @_;
558 return $self->_relationships->{$rel};
561 =head2 has_relationship
565 =item Arguments: $rel
569 Returns true if the source has a relationship of this name, false otherwise.
573 sub has_relationship {
574 my ($self, $rel) = @_;
575 return exists $self->_relationships->{$rel};
578 =head2 reverse_relationship_info
582 =item Arguments: $relname
586 Returns an array of hash references of relationship information for
587 the other side of the specified relationship name.
591 sub reverse_relationship_info {
592 my ($self, $rel) = @_;
593 my $rel_info = $self->relationship_info($rel);
596 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
598 my @cond = keys(%{$rel_info->{cond}});
599 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
600 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
602 # Get the related result source for this relationship
603 my $othertable = $self->related_source($rel);
605 # Get all the relationships for that source that related to this source
606 # whose foreign column set are our self columns on $rel and whose self
607 # columns are our foreign columns on $rel.
608 my @otherrels = $othertable->relationships();
609 my $otherrelationship;
610 foreach my $otherrel (@otherrels) {
611 my $otherrel_info = $othertable->relationship_info($otherrel);
613 my $back = $othertable->related_source($otherrel);
614 next unless $back->name eq $self->name;
618 if (ref $otherrel_info->{cond} eq 'HASH') {
619 @othertestconds = ($otherrel_info->{cond});
621 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
622 @othertestconds = @{$otherrel_info->{cond}};
628 foreach my $othercond (@othertestconds) {
629 my @other_cond = keys(%$othercond);
630 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
631 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
632 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
633 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
634 $ret->{$otherrel} = $otherrel_info;
640 =head2 compare_relationship_keys
644 =item Arguments: $keys1, $keys2
648 Returns true if both sets of keynames are the same, false otherwise.
652 sub compare_relationship_keys {
653 my ($self, $keys1, $keys2) = @_;
655 # Make sure every keys1 is in keys2
657 foreach my $key (@$keys1) {
659 foreach my $prim (@$keys2) {
668 # Make sure every key2 is in key1
670 foreach my $prim (@$keys2) {
672 foreach my $key (@$keys1) {
689 =item Arguments: $relation
693 Returns the join structure required for the related result source.
698 my ($self, $join, $alias, $seen) = @_;
700 if (ref $join eq 'ARRAY') {
701 return map { $self->resolve_join($_, $alias, $seen) } @$join;
702 } elsif (ref $join eq 'HASH') {
705 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
706 ($self->resolve_join($_, $alias, $seen),
707 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
709 } elsif (ref $join) {
710 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
712 my $count = ++$seen->{$join};
713 #use Data::Dumper; warn Dumper($seen);
714 my $as = ($count > 1 ? "${join}_${count}" : $join);
715 my $rel_info = $self->relationship_info($join);
716 $self->throw_exception("No such relationship ${join}") unless $rel_info;
717 my $type = $rel_info->{attrs}{join_type} || '';
718 return [ { $as => $self->related_source($join)->from,
719 -join_type => $type },
720 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
724 =head2 resolve_condition
728 =item Arguments: $cond, $as, $alias|$object
732 Resolves the passed condition to a concrete query fragment. If given an alias,
733 returns a join condition; if given an object, inverts that object to produce
734 a related conditional from that object.
738 sub resolve_condition {
739 my ($self, $cond, $as, $for) = @_;
741 if (ref $cond eq 'HASH') {
743 foreach my $k (keys %{$cond}) {
745 # XXX should probably check these are valid columns
746 $k =~ s/^foreign\.// ||
747 $self->throw_exception("Invalid rel cond key ${k}");
749 $self->throw_exception("Invalid rel cond val ${v}");
750 if (ref $for) { # Object
751 #warn "$self $k $for $v";
752 $ret{$k} = $for->get_column($v);
754 } elsif (!defined $for) { # undef, i.e. "no object"
756 } elsif (ref $as) { # reverse object
757 $ret{$v} = $as->get_column($k);
758 } elsif (!defined $as) { # undef, i.e. "no reverse object"
761 $ret{"${as}.${k}"} = "${for}.${v}";
765 } elsif (ref $cond eq 'ARRAY') {
766 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
768 die("Can't handle this yet :(");
772 =head2 resolve_prefetch
776 =item Arguments: hashref/arrayref/scalar
780 Accepts one or more relationships for the current source and returns an
781 array of column names for each of those relationships. Column names are
782 prefixed relative to the current source, in accordance with where they appear
783 in the supplied relationships. Examples:
785 my $source = $schema->resultset('Tag')->source;
786 @columns = $source->resolve_prefetch( { cd => 'artist' } );
794 # 'cd.artist.artistid',
798 @columns = $source->resolve_prefetch( qw[/ cd /] );
808 $source = $schema->resultset('CD')->source;
809 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
815 # 'producer.producerid',
821 sub resolve_prefetch {
822 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
824 #$alias ||= $self->name;
825 #warn $alias, Dumper $pre;
826 if( ref $pre eq 'ARRAY' ) {
828 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
831 elsif( ref $pre eq 'HASH' ) {
834 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
835 $self->related_source($_)->resolve_prefetch(
836 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
842 $self->throw_exception(
843 "don't know how to resolve prefetch reftype ".ref($pre));
846 my $count = ++$seen->{$pre};
847 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
848 my $rel_info = $self->relationship_info( $pre );
849 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
851 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
852 my $rel_source = $self->related_source($pre);
854 if (exists $rel_info->{attrs}{accessor}
855 && $rel_info->{attrs}{accessor} eq 'multi') {
856 $self->throw_exception(
857 "Can't prefetch has_many ${pre} (join cond too complex)")
858 unless ref($rel_info->{cond}) eq 'HASH';
859 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
860 keys %{$rel_info->{cond}};
861 $collapse->{"${as_prefix}${pre}"} = \@key;
862 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
863 ? @{$rel_info->{attrs}{order_by}}
864 : (defined $rel_info->{attrs}{order_by}
865 ? ($rel_info->{attrs}{order_by})
867 push(@$order, map { "${as}.$_" } (@key, @ord));
870 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
871 $rel_source->columns;
872 #warn $alias, Dumper (\@ret);
877 =head2 related_source
881 =item Arguments: $relname
885 Returns the result source object for the given relationship.
890 my ($self, $rel) = @_;
891 if( !$self->has_relationship( $rel ) ) {
892 $self->throw_exception("No such relationship '$rel'");
894 return $self->schema->source($self->relationship_info($rel)->{source});
901 =item Arguments: $relname
905 Returns the class name for objects in the given relationship.
910 my ($self, $rel) = @_;
911 if( !$self->has_relationship( $rel ) ) {
912 $self->throw_exception("No such relationship '$rel'");
914 return $self->schema->class($self->relationship_info($rel)->{source});
919 Returns a resultset for the given source. This will initially be created
922 $self->resultset_class->new($self, $self->resultset_attributes)
924 but is cached from then on unless resultset_class changes.
926 =head2 resultset_class
928 Set the class of the resultset, this is useful if you want to create your
929 own resultset methods. Create your own class derived from
930 L<DBIx::Class::ResultSet>, and set it here.
932 =head2 resultset_attributes
934 Specify here any attributes you wish to pass to your specialised resultset.
940 $self->throw_exception(
941 'resultset does not take any arguments. If you want another resultset, '.
942 'call it on the schema instead.'
945 # disabled until we can figure out a way to do it without consistency issues
947 #return $self->{_resultset}
948 # if ref $self->{_resultset} eq $self->resultset_class;
949 #return $self->{_resultset} =
951 return $self->resultset_class->new(
952 $self, $self->{resultset_attributes}
960 =item Arguments: $source_name
964 Set the name of the result source when it is loaded into a schema.
965 This is usefull if you want to refer to a result source by a name other than
968 package ArchivedBooks;
969 use base qw/DBIx::Class/;
970 __PACKAGE__->table('books_archive');
971 __PACKAGE__->source_name('Books');
973 # from your schema...
974 $schema->resultset('Books')->find(1);
976 =head2 throw_exception
978 See L<DBIx::Class::Schema/"throw_exception">.
982 sub throw_exception {
984 if (defined $self->schema) {
985 $self->schema->throw_exception(@_);
993 Matt S. Trout <mst@shadowcatsystems.co.uk>
997 You may distribute this code under the same terms as Perl itself.