1 package DBIx::Class::ResultSource;
6 use DBIx::Class::ResultSet;
7 use DBIx::Class::ResultSourceHandle;
8 use Carp::Clan qw/^DBIx::Class/;
11 use base qw/DBIx::Class/;
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_info
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 = bless { %{$attrs || {}} }, $class;
51 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
52 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
53 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
54 $new->{_columns} = { %{$new->{_columns}||{}} };
55 $new->{_relationships} = { %{$new->{_relationships}||{}} };
56 $new->{name} ||= "!!NAME NOT SET!!";
57 $new->{_columns_info_loaded} ||= 0;
65 Stores a hashref of per-source metadata. No specific key names
66 have yet been standardized, the examples below are purely hypothetical
67 and don't actually accomplish anything on their own:
69 __PACKAGE__->source_info({
70 "_tablespace" => 'fast_disk_array_3',
71 "_engine" => 'InnoDB',
76 $table->add_columns(qw/col1 col2 col3/);
78 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
80 Adds columns to the result source. If supplied key => hashref pairs, uses
81 the hashref as the column_info for that column. Repeated calls of this
82 method will add more columns, not replace them.
84 The column names given will be created as accessor methods on your
85 L<DBIx::Class::Row> objects, you can change the name of the accessor
86 by supplying an L</accessor> in the column_info hash.
88 The contents of the column_info are not set in stone. The following
89 keys are currently recognised/used by DBIx::Class:
95 Use this to set the name of the accessor method for this column. If unset,
96 the name of the column will be used.
100 This contains the column type. It is automatically filled by the
101 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
102 L<DBIx::Class::Schema::Loader> module. If you do not enter a
103 data_type, DBIx::Class will attempt to retrieve it from the
104 database for you, using L<DBI>'s column_info method. The values of this
105 key are typically upper-cased.
107 Currently there is no standard set of values for the data_type. Use
108 whatever your database supports.
112 The length of your column, if it is a column type that can have a size
113 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
117 Set this to a true value for a columns that is allowed to contain
118 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
120 =item is_auto_increment
122 Set this to a true value for a column whose value is somehow
123 automatically set. This is used to determine which columns to empty
124 when cloning objects using C<copy>. It is also used by
125 L<DBIx::Class::Schema/deploy>.
129 Set this to a true value for a column that contains a key from a
130 foreign table. This is currently only used by
131 L<DBIx::Class::Schema/deploy>.
135 Set this to the default value which will be inserted into a column
136 by the database. Can contain either a value or a function. This is
137 currently only used by L<DBIx::Class::Schema/deploy>.
141 Set this on a primary key column to the name of the sequence used to
142 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
143 will attempt to retrieve the name of the sequence from the database
148 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
149 to add extra non-generic data to the column. For example: C<< extra
150 => { unsigned => 1} >> is used by the MySQL producer to set an integer
151 column to unsigned. For more details, see
152 L<SQL::Translator::Producer::MySQL>.
158 $table->add_column('col' => \%info?);
160 Convenience alias to add_columns.
165 my ($self, @cols) = @_;
166 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
169 my $columns = $self->_columns;
170 while (my $col = shift @cols) {
171 # If next entry is { ... } use that for the column info, if not
172 # use an empty hashref
173 my $column_info = ref $cols[0] ? shift(@cols) : {};
174 push(@added, $col) unless exists $columns->{$col};
175 $columns->{$col} = $column_info;
177 push @{ $self->_ordered_columns }, @added;
181 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
185 if ($obj->has_column($col)) { ... }
187 Returns true if the source has a column of this name, false otherwise.
192 my ($self, $column) = @_;
193 return exists $self->_columns->{$column};
198 my $info = $obj->column_info($col);
200 Returns the column metadata hashref for a column. See the description
201 of add_column for information on the contents of the hashref.
206 my ($self, $column) = @_;
207 $self->throw_exception("No such column $column")
208 unless exists $self->_columns->{$column};
209 #warn $self->{_columns_info_loaded}, "\n";
210 if ( ! $self->_columns->{$column}{data_type}
211 and $self->column_info_from_storage
212 and ! $self->{_columns_info_loaded}
213 and $self->schema and $self->storage )
215 $self->{_columns_info_loaded}++;
218 # eval for the case of storage without table
219 eval { $info = $self->storage->columns_info_for( $self->from ) };
221 for my $realcol ( keys %{$info} ) {
222 $lc_info->{lc $realcol} = $info->{$realcol};
224 foreach my $col ( keys %{$self->_columns} ) {
225 $self->_columns->{$col} = {
226 %{ $self->_columns->{$col} },
227 %{ $info->{$col} || $lc_info->{lc $col} || {} }
232 return $self->_columns->{$column};
235 =head2 column_info_from_storage
237 Enables the on-demand automatic loading of the above column
238 metadata from storage as neccesary. This is *deprecated*, and
239 should not be used. It will be removed before 1.0.
241 __PACKAGE__->column_info_from_storage(1);
245 my @column_names = $obj->columns;
247 Returns all column names in the order they were declared to add_columns.
253 $self->throw_exception(
254 "columns() is a read-only accessor, did you mean add_columns()?"
256 return @{$self->{_ordered_columns}||[]};
259 =head2 remove_columns
261 $table->remove_columns(qw/col1 col2 col3/);
263 Removes columns from the result source.
267 $table->remove_column('col');
269 Convenience alias to remove_columns.
274 my ($self, @cols) = @_;
276 return unless $self->_ordered_columns;
278 my $columns = $self->_columns;
281 foreach my $col (@{$self->_ordered_columns}) {
282 push @remaining, $col unless grep(/$col/, @cols);
286 delete $columns->{$_};
289 $self->_ordered_columns(\@remaining);
292 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
294 =head2 set_primary_key
298 =item Arguments: @cols
302 Defines one or more columns as primary key for this source. Should be
303 called after C<add_columns>.
305 Additionally, defines a unique constraint named C<primary>.
307 The primary key columns are used by L<DBIx::Class::PK::Auto> to
308 retrieve automatically created values from the database.
312 sub set_primary_key {
313 my ($self, @cols) = @_;
314 # check if primary key columns are valid columns
315 foreach my $col (@cols) {
316 $self->throw_exception("No such column $col on table " . $self->name)
317 unless $self->has_column($col);
319 $self->_primaries(\@cols);
321 $self->add_unique_constraint(primary => \@cols);
324 =head2 primary_columns
326 Read-only accessor which returns the list of primary keys.
330 sub primary_columns {
331 return @{shift->_primaries||[]};
334 =head2 add_unique_constraint
336 Declare a unique constraint on this source. Call once for each unique
339 # For UNIQUE (column1, column2)
340 __PACKAGE__->add_unique_constraint(
341 constraint_name => [ qw/column1 column2/ ],
344 Alternatively, you can specify only the columns:
346 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
348 This will result in a unique constraint named C<table_column1_column2>, where
349 C<table> is replaced with the table name.
351 Unique constraints are used, for example, when you call
352 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
356 sub add_unique_constraint {
361 $name ||= $self->name_unique_constraint($cols);
363 foreach my $col (@$cols) {
364 $self->throw_exception("No such column $col on table " . $self->name)
365 unless $self->has_column($col);
368 my %unique_constraints = $self->unique_constraints;
369 $unique_constraints{$name} = $cols;
370 $self->_unique_constraints(\%unique_constraints);
373 =head2 name_unique_constraint
375 Return a name for a unique constraint containing the specified columns. These
376 names consist of the table name and each column name, separated by underscores.
378 For example, a constraint on a table named C<cd> containing the columns
379 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
383 sub name_unique_constraint {
384 my ($self, $cols) = @_;
386 return join '_', $self->name, @$cols;
389 =head2 unique_constraints
391 Read-only accessor which returns the list of unique constraints on this source.
395 sub unique_constraints {
396 return %{shift->_unique_constraints||{}};
399 =head2 unique_constraint_names
401 Returns the list of unique constraint names defined on this source.
405 sub unique_constraint_names {
408 my %unique_constraints = $self->unique_constraints;
410 return keys %unique_constraints;
413 =head2 unique_constraint_columns
415 Returns the list of columns that make up the specified unique constraint.
419 sub unique_constraint_columns {
420 my ($self, $constraint_name) = @_;
422 my %unique_constraints = $self->unique_constraints;
424 $self->throw_exception(
425 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
426 ) unless exists $unique_constraints{$constraint_name};
428 return @{ $unique_constraints{$constraint_name} };
433 Returns an expression of the source to be supplied to storage to specify
434 retrieval from this source. In the case of a database, the required FROM
439 Returns the L<DBIx::Class::Schema> object that this result source
444 Returns the storage handle for the current schema.
446 See also: L<DBIx::Class::Storage>
450 sub storage { shift->schema->storage; }
452 =head2 add_relationship
454 $source->add_relationship('relname', 'related_source', $cond, $attrs);
456 The relationship name can be arbitrary, but must be unique for each
457 relationship attached to this result source. 'related_source' should
458 be the name with which the related result source was registered with
459 the current schema. For example:
461 $schema->source('Book')->add_relationship('reviews', 'Review', {
462 'foreign.book_id' => 'self.id',
465 The condition C<$cond> needs to be an L<SQL::Abstract>-style
466 representation of the join between the tables. For example, if you're
467 creating a rel from Author to Book,
469 { 'foreign.author_id' => 'self.id' }
471 will result in the JOIN clause
473 author me JOIN book foreign ON foreign.author_id = me.id
475 You can specify as many foreign => self mappings as necessary.
477 Valid attributes are as follows:
483 Explicitly specifies the type of join to use in the relationship. Any
484 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
485 the SQL command immediately before C<JOIN>.
489 An arrayref containing a list of accessors in the foreign class to proxy in
490 the main class. If, for example, you do the following:
492 CD->might_have(liner_notes => 'LinerNotes', undef, {
493 proxy => [ qw/notes/ ],
496 Then, assuming LinerNotes has an accessor named notes, you can do:
498 my $cd = CD->find(1);
499 # set notes -- LinerNotes object is created if it doesn't exist
500 $cd->notes('Notes go here');
504 Specifies the type of accessor that should be created for the
505 relationship. Valid values are C<single> (for when there is only a single
506 related object), C<multi> (when there can be many), and C<filter> (for
507 when there is a single related object, but you also want the relationship
508 accessor to double as a column accessor). For C<multi> accessors, an
509 add_to_* method is also created, which calls C<create_related> for the
516 sub add_relationship {
517 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
518 $self->throw_exception("Can't create relationship without join condition")
522 my %rels = %{ $self->_relationships };
523 $rels{$rel} = { class => $f_source_name,
524 source => $f_source_name,
527 $self->_relationships(\%rels);
531 # XXX disabled. doesn't work properly currently. skip in tests.
533 my $f_source = $self->schema->source($f_source_name);
535 $self->ensure_class_loaded($f_source_name);
536 $f_source = $f_source_name->result_source;
537 #my $s_class = ref($self->schema);
538 #$f_source_name =~ m/^${s_class}::(.*)$/;
539 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
540 #$f_source = $self->schema->source($f_source_name);
542 return unless $f_source; # Can't test rel without f_source
544 eval { $self->resolve_join($rel, 'me') };
546 if ($@) { # If the resolve failed, back out and re-throw the error
547 delete $rels{$rel}; #
548 $self->_relationships(\%rels);
549 $self->throw_exception("Error creating relationship $rel: $@");
556 Returns all relationship names for this source.
561 return keys %{shift->_relationships};
564 =head2 relationship_info
568 =item Arguments: $relname
572 Returns a hash of relationship information for the specified relationship
577 sub relationship_info {
578 my ($self, $rel) = @_;
579 return $self->_relationships->{$rel};
582 =head2 has_relationship
586 =item Arguments: $rel
590 Returns true if the source has a relationship of this name, false otherwise.
594 sub has_relationship {
595 my ($self, $rel) = @_;
596 return exists $self->_relationships->{$rel};
599 =head2 reverse_relationship_info
603 =item Arguments: $relname
607 Returns an array of hash references of relationship information for
608 the other side of the specified relationship name.
612 sub reverse_relationship_info {
613 my ($self, $rel) = @_;
614 my $rel_info = $self->relationship_info($rel);
617 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
619 my @cond = keys(%{$rel_info->{cond}});
620 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
621 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
623 # Get the related result source for this relationship
624 my $othertable = $self->related_source($rel);
626 # Get all the relationships for that source that related to this source
627 # whose foreign column set are our self columns on $rel and whose self
628 # columns are our foreign columns on $rel.
629 my @otherrels = $othertable->relationships();
630 my $otherrelationship;
631 foreach my $otherrel (@otherrels) {
632 my $otherrel_info = $othertable->relationship_info($otherrel);
634 my $back = $othertable->related_source($otherrel);
635 next unless $back->name eq $self->name;
639 if (ref $otherrel_info->{cond} eq 'HASH') {
640 @othertestconds = ($otherrel_info->{cond});
642 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
643 @othertestconds = @{$otherrel_info->{cond}};
649 foreach my $othercond (@othertestconds) {
650 my @other_cond = keys(%$othercond);
651 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
652 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
653 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
654 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
655 $ret->{$otherrel} = $otherrel_info;
661 =head2 compare_relationship_keys
665 =item Arguments: $keys1, $keys2
669 Returns true if both sets of keynames are the same, false otherwise.
673 sub compare_relationship_keys {
674 my ($self, $keys1, $keys2) = @_;
676 # Make sure every keys1 is in keys2
678 foreach my $key (@$keys1) {
680 foreach my $prim (@$keys2) {
689 # Make sure every key2 is in key1
691 foreach my $prim (@$keys2) {
693 foreach my $key (@$keys1) {
710 =item Arguments: $relation
714 Returns the join structure required for the related result source.
719 my ($self, $join, $alias, $seen, $force_left) = @_;
721 $force_left ||= { force => 0 };
722 if (ref $join eq 'ARRAY') {
723 return map { $self->resolve_join($_, $alias, $seen) } @$join;
724 } elsif (ref $join eq 'HASH') {
727 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
728 local $force_left->{force};
730 $self->resolve_join($_, $alias, $seen, $force_left),
731 $self->related_source($_)->resolve_join(
732 $join->{$_}, $as, $seen, $force_left
736 } elsif (ref $join) {
737 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
739 my $count = ++$seen->{$join};
740 #use Data::Dumper; warn Dumper($seen);
741 my $as = ($count > 1 ? "${join}_${count}" : $join);
742 my $rel_info = $self->relationship_info($join);
743 $self->throw_exception("No such relationship ${join}") unless $rel_info;
745 if ($force_left->{force}) {
748 $type = $rel_info->{attrs}{join_type} || '';
749 $force_left->{force} = 1 if lc($type) eq 'left';
751 return [ { $as => $self->related_source($join)->from,
752 -join_type => $type },
753 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
757 =head2 resolve_condition
761 =item Arguments: $cond, $as, $alias|$object
765 Resolves the passed condition to a concrete query fragment. If given an alias,
766 returns a join condition; if given an object, inverts that object to produce
767 a related conditional from that object.
771 sub resolve_condition {
772 my ($self, $cond, $as, $for) = @_;
774 if (ref $cond eq 'HASH') {
776 foreach my $k (keys %{$cond}) {
778 # XXX should probably check these are valid columns
779 $k =~ s/^foreign\.// ||
780 $self->throw_exception("Invalid rel cond key ${k}");
782 $self->throw_exception("Invalid rel cond val ${v}");
783 if (ref $for) { # Object
784 #warn "$self $k $for $v";
785 $ret{$k} = $for->get_column($v);
787 } elsif (!defined $for) { # undef, i.e. "no object"
789 } elsif (ref $as eq 'HASH') { # reverse hashref
790 $ret{$v} = $as->{$k};
791 } elsif (ref $as) { # reverse object
792 $ret{$v} = $as->get_column($k);
793 } elsif (!defined $as) { # undef, i.e. "no reverse object"
796 $ret{"${as}.${k}"} = "${for}.${v}";
800 } elsif (ref $cond eq 'ARRAY') {
801 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
803 die("Can't handle this yet :(");
807 =head2 resolve_prefetch
811 =item Arguments: hashref/arrayref/scalar
815 Accepts one or more relationships for the current source and returns an
816 array of column names for each of those relationships. Column names are
817 prefixed relative to the current source, in accordance with where they appear
818 in the supplied relationships. Examples:
820 my $source = $schema->resultset('Tag')->source;
821 @columns = $source->resolve_prefetch( { cd => 'artist' } );
829 # 'cd.artist.artistid',
833 @columns = $source->resolve_prefetch( qw[/ cd /] );
843 $source = $schema->resultset('CD')->source;
844 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
850 # 'producer.producerid',
856 sub resolve_prefetch {
857 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
859 #$alias ||= $self->name;
860 #warn $alias, Dumper $pre;
861 if( ref $pre eq 'ARRAY' ) {
863 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
866 elsif( ref $pre eq 'HASH' ) {
869 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
870 $self->related_source($_)->resolve_prefetch(
871 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
877 $self->throw_exception(
878 "don't know how to resolve prefetch reftype ".ref($pre));
881 my $count = ++$seen->{$pre};
882 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
883 my $rel_info = $self->relationship_info( $pre );
884 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
886 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
887 my $rel_source = $self->related_source($pre);
889 if (exists $rel_info->{attrs}{accessor}
890 && $rel_info->{attrs}{accessor} eq 'multi') {
891 $self->throw_exception(
892 "Can't prefetch has_many ${pre} (join cond too complex)")
893 unless ref($rel_info->{cond}) eq 'HASH';
894 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
895 # values %{$rel_info->{cond}};
896 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
897 # action at a distance. prepending the '.' allows simpler code
898 # in ResultSet->_collapse_result
899 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
900 keys %{$rel_info->{cond}};
901 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
902 ? @{$rel_info->{attrs}{order_by}}
903 : (defined $rel_info->{attrs}{order_by}
904 ? ($rel_info->{attrs}{order_by})
906 push(@$order, map { "${as}.$_" } (@key, @ord));
909 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
910 $rel_source->columns;
911 #warn $alias, Dumper (\@ret);
916 =head2 related_source
920 =item Arguments: $relname
924 Returns the result source object for the given relationship.
929 my ($self, $rel) = @_;
930 if( !$self->has_relationship( $rel ) ) {
931 $self->throw_exception("No such relationship '$rel'");
933 return $self->schema->source($self->relationship_info($rel)->{source});
940 =item Arguments: $relname
944 Returns the class name for objects in the given relationship.
949 my ($self, $rel) = @_;
950 if( !$self->has_relationship( $rel ) ) {
951 $self->throw_exception("No such relationship '$rel'");
953 return $self->schema->class($self->relationship_info($rel)->{source});
958 Returns a resultset for the given source. This will initially be created
961 $self->resultset_class->new($self, $self->resultset_attributes)
963 but is cached from then on unless resultset_class changes.
965 =head2 resultset_class
967 ` package My::ResultSetClass;
968 use base 'DBIx::Class::ResultSet';
971 $source->resultset_class('My::ResultSet::Class');
973 Set the class of the resultset, this is useful if you want to create your
974 own resultset methods. Create your own class derived from
975 L<DBIx::Class::ResultSet>, and set it here.
977 =head2 resultset_attributes
979 $source->resultset_attributes({ order_by => [ 'id' ] });
981 Specify here any attributes you wish to pass to your specialised
982 resultset. For a full list of these, please see
983 L<DBIx::Class::ResultSet/ATTRIBUTES>.
989 $self->throw_exception(
990 'resultset does not take any arguments. If you want another resultset, '.
991 'call it on the schema instead.'
994 return $self->resultset_class->new(
997 %{$self->{resultset_attributes}},
998 %{$self->schema->default_resultset_attributes}
1007 =item Arguments: $source_name
1011 Set the name of the result source when it is loaded into a schema.
1012 This is usefull if you want to refer to a result source by a name other than
1015 package ArchivedBooks;
1016 use base qw/DBIx::Class/;
1017 __PACKAGE__->table('books_archive');
1018 __PACKAGE__->source_name('Books');
1020 # from your schema...
1021 $schema->resultset('Books')->find(1);
1025 Obtain a new handle to this source. Returns an instance of a
1026 L<DBIx::Class::ResultSourceHandle>.
1031 return new DBIx::Class::ResultSourceHandle({
1032 schema => $_[0]->schema,
1033 source_moniker => $_[0]->source_name
1037 =head2 throw_exception
1039 See L<DBIx::Class::Schema/"throw_exception">.
1043 sub throw_exception {
1045 if (defined $self->schema) {
1046 $self->schema->throw_exception(@_);
1054 Matt S. Trout <mst@shadowcatsystems.co.uk>
1058 You may distribute this code under the same terms as Perl itself.