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 contents of the column_info are not set in stone. The following
85 keys are currently recognised/used by DBIx::Class:
91 Use this to set the name of the accessor for this column. If unset,
92 the name of the column will be used.
96 This contains the column type. It is automatically filled by the
97 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
98 L<DBIx::Class::Schema::Loader> module. If you do not enter a
99 data_type, DBIx::Class will attempt to retrieve it from the
100 database for you, using L<DBI>'s column_info method. The values of this
101 key are typically upper-cased.
103 Currently there is no standard set of values for the data_type. Use
104 whatever your database supports.
108 The length of your column, if it is a column type that can have a size
109 restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
113 Set this to a true value for a columns that is allowed to contain
114 NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
116 =item is_auto_increment
118 Set this to a true value for a column whose value is somehow
119 automatically set. This is used to determine which columns to empty
120 when cloning objects using C<copy>. It is also used by
121 L<DBIx::Class::Schema/deploy>.
125 Set this to a true value for a column that contains a key from a
126 foreign table. This is currently only used by
127 L<DBIx::Class::Schema/deploy>.
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 only used by L<DBIx::Class::Schema/deploy>.
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
144 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
145 to add extra non-generic data to the column. For example: C<< extra
146 => { unsigned => 1} >> is used by the MySQL producer to set an integer
147 column to unsigned. For more details, see
148 L<SQL::Translator::Producer::MySQL>.
154 $table->add_column('col' => \%info?);
156 Convenience alias to add_columns.
161 my ($self, @cols) = @_;
162 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
165 my $columns = $self->_columns;
166 while (my $col = shift @cols) {
167 # If next entry is { ... } use that for the column info, if not
168 # use an empty hashref
169 my $column_info = ref $cols[0] ? shift(@cols) : {};
170 push(@added, $col) unless exists $columns->{$col};
171 $columns->{$col} = $column_info;
173 push @{ $self->_ordered_columns }, @added;
177 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
181 if ($obj->has_column($col)) { ... }
183 Returns true if the source has a column of this name, false otherwise.
188 my ($self, $column) = @_;
189 return exists $self->_columns->{$column};
194 my $info = $obj->column_info($col);
196 Returns the column metadata hashref for a column. See the description
197 of add_column for information on the contents of the hashref.
202 my ($self, $column) = @_;
203 $self->throw_exception("No such column $column")
204 unless exists $self->_columns->{$column};
205 #warn $self->{_columns_info_loaded}, "\n";
206 if ( ! $self->_columns->{$column}{data_type}
207 and $self->column_info_from_storage
208 and ! $self->{_columns_info_loaded}
209 and $self->schema and $self->storage )
211 $self->{_columns_info_loaded}++;
214 # eval for the case of storage without table
215 eval { $info = $self->storage->columns_info_for( $self->from ) };
217 for my $realcol ( keys %{$info} ) {
218 $lc_info->{lc $realcol} = $info->{$realcol};
220 foreach my $col ( keys %{$self->_columns} ) {
221 $self->_columns->{$col} = {
222 %{ $self->_columns->{$col} },
223 %{ $info->{$col} || $lc_info->{lc $col} || {} }
228 return $self->_columns->{$column};
231 =head2 column_info_from_storage
233 Enables the on-demand automatic loading of the above column
234 metadata from storage as neccesary. This is *deprecated*, and
235 should not be used. It will be removed before 1.0.
237 __PACKAGE__->column_info_from_storage(1);
241 my @column_names = $obj->columns;
243 Returns all column names in the order they were declared to add_columns.
249 $self->throw_exception(
250 "columns() is a read-only accessor, did you mean add_columns()?"
252 return @{$self->{_ordered_columns}||[]};
255 =head2 remove_columns
257 $table->remove_columns(qw/col1 col2 col3/);
259 Removes columns from the result source.
263 $table->remove_column('col');
265 Convenience alias to remove_columns.
270 my ($self, @cols) = @_;
272 return unless $self->_ordered_columns;
274 my $columns = $self->_columns;
277 foreach my $col (@{$self->_ordered_columns}) {
278 push @remaining, $col unless grep(/$col/, @cols);
282 delete $columns->{$_};
285 $self->_ordered_columns(\@remaining);
288 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
290 =head2 set_primary_key
294 =item Arguments: @cols
298 Defines one or more columns as primary key for this source. Should be
299 called after C<add_columns>.
301 Additionally, defines a unique constraint named C<primary>.
303 The primary key columns are used by L<DBIx::Class::PK::Auto> to
304 retrieve automatically created values from the database.
308 sub set_primary_key {
309 my ($self, @cols) = @_;
310 # check if primary key columns are valid columns
311 foreach my $col (@cols) {
312 $self->throw_exception("No such column $col on table " . $self->name)
313 unless $self->has_column($col);
315 $self->_primaries(\@cols);
317 $self->add_unique_constraint(primary => \@cols);
320 =head2 primary_columns
322 Read-only accessor which returns the list of primary keys.
326 sub primary_columns {
327 return @{shift->_primaries||[]};
330 =head2 add_unique_constraint
332 Declare a unique constraint on this source. Call once for each unique
335 # For UNIQUE (column1, column2)
336 __PACKAGE__->add_unique_constraint(
337 constraint_name => [ qw/column1 column2/ ],
340 Alternatively, you can specify only the columns:
342 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
344 This will result in a unique constraint named C<table_column1_column2>, where
345 C<table> is replaced with the table name.
347 Unique constraints are used, for example, when you call
348 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
352 sub add_unique_constraint {
357 $name ||= $self->name_unique_constraint($cols);
359 foreach my $col (@$cols) {
360 $self->throw_exception("No such column $col on table " . $self->name)
361 unless $self->has_column($col);
364 my %unique_constraints = $self->unique_constraints;
365 $unique_constraints{$name} = $cols;
366 $self->_unique_constraints(\%unique_constraints);
369 =head2 name_unique_constraint
371 Return a name for a unique constraint containing the specified columns. These
372 names consist of the table name and each column name, separated by underscores.
374 For example, a constraint on a table named C<cd> containing the columns
375 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
379 sub name_unique_constraint {
380 my ($self, $cols) = @_;
382 return join '_', $self->name, @$cols;
385 =head2 unique_constraints
387 Read-only accessor which returns the list of unique constraints on this source.
391 sub unique_constraints {
392 return %{shift->_unique_constraints||{}};
395 =head2 unique_constraint_names
397 Returns the list of unique constraint names defined on this source.
401 sub unique_constraint_names {
404 my %unique_constraints = $self->unique_constraints;
406 return keys %unique_constraints;
409 =head2 unique_constraint_columns
411 Returns the list of columns that make up the specified unique constraint.
415 sub unique_constraint_columns {
416 my ($self, $constraint_name) = @_;
418 my %unique_constraints = $self->unique_constraints;
420 $self->throw_exception(
421 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
422 ) unless exists $unique_constraints{$constraint_name};
424 return @{ $unique_constraints{$constraint_name} };
429 Returns an expression of the source to be supplied to storage to specify
430 retrieval from this source. In the case of a database, the required FROM
435 Returns the L<DBIx::Class::Schema> object that this result source
440 Returns the storage handle for the current schema.
442 See also: L<DBIx::Class::Storage>
446 sub storage { shift->schema->storage; }
448 =head2 add_relationship
450 $source->add_relationship('relname', 'related_source', $cond, $attrs);
452 The relationship name can be arbitrary, but must be unique for each
453 relationship attached to this result source. 'related_source' should
454 be the name with which the related result source was registered with
455 the current schema. For example:
457 $schema->source('Book')->add_relationship('reviews', 'Review', {
458 'foreign.book_id' => 'self.id',
461 The condition C<$cond> needs to be an L<SQL::Abstract>-style
462 representation of the join between the tables. For example, if you're
463 creating a rel from Author to Book,
465 { 'foreign.author_id' => 'self.id' }
467 will result in the JOIN clause
469 author me JOIN book foreign ON foreign.author_id = me.id
471 You can specify as many foreign => self mappings as necessary.
473 Valid attributes are as follows:
479 Explicitly specifies the type of join to use in the relationship. Any
480 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
481 the SQL command immediately before C<JOIN>.
485 An arrayref containing a list of accessors in the foreign class to proxy in
486 the main class. If, for example, you do the following:
488 CD->might_have(liner_notes => 'LinerNotes', undef, {
489 proxy => [ qw/notes/ ],
492 Then, assuming LinerNotes has an accessor named notes, you can do:
494 my $cd = CD->find(1);
495 # set notes -- LinerNotes object is created if it doesn't exist
496 $cd->notes('Notes go here');
500 Specifies the type of accessor that should be created for the
501 relationship. Valid values are C<single> (for when there is only a single
502 related object), C<multi> (when there can be many), and C<filter> (for
503 when there is a single related object, but you also want the relationship
504 accessor to double as a column accessor). For C<multi> accessors, an
505 add_to_* method is also created, which calls C<create_related> for the
512 sub add_relationship {
513 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
514 $self->throw_exception("Can't create relationship without join condition")
518 my %rels = %{ $self->_relationships };
519 $rels{$rel} = { class => $f_source_name,
520 source => $f_source_name,
523 $self->_relationships(\%rels);
527 # XXX disabled. doesn't work properly currently. skip in tests.
529 my $f_source = $self->schema->source($f_source_name);
531 $self->ensure_class_loaded($f_source_name);
532 $f_source = $f_source_name->result_source;
533 #my $s_class = ref($self->schema);
534 #$f_source_name =~ m/^${s_class}::(.*)$/;
535 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
536 #$f_source = $self->schema->source($f_source_name);
538 return unless $f_source; # Can't test rel without f_source
540 eval { $self->resolve_join($rel, 'me') };
542 if ($@) { # If the resolve failed, back out and re-throw the error
543 delete $rels{$rel}; #
544 $self->_relationships(\%rels);
545 $self->throw_exception("Error creating relationship $rel: $@");
552 Returns all relationship names for this source.
557 return keys %{shift->_relationships};
560 =head2 relationship_info
564 =item Arguments: $relname
568 Returns a hash of relationship information for the specified relationship
573 sub relationship_info {
574 my ($self, $rel) = @_;
575 return $self->_relationships->{$rel};
578 =head2 has_relationship
582 =item Arguments: $rel
586 Returns true if the source has a relationship of this name, false otherwise.
590 sub has_relationship {
591 my ($self, $rel) = @_;
592 return exists $self->_relationships->{$rel};
595 =head2 reverse_relationship_info
599 =item Arguments: $relname
603 Returns an array of hash references of relationship information for
604 the other side of the specified relationship name.
608 sub reverse_relationship_info {
609 my ($self, $rel) = @_;
610 my $rel_info = $self->relationship_info($rel);
613 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
615 my @cond = keys(%{$rel_info->{cond}});
616 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
617 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
619 # Get the related result source for this relationship
620 my $othertable = $self->related_source($rel);
622 # Get all the relationships for that source that related to this source
623 # whose foreign column set are our self columns on $rel and whose self
624 # columns are our foreign columns on $rel.
625 my @otherrels = $othertable->relationships();
626 my $otherrelationship;
627 foreach my $otherrel (@otherrels) {
628 my $otherrel_info = $othertable->relationship_info($otherrel);
630 my $back = $othertable->related_source($otherrel);
631 next unless $back->name eq $self->name;
635 if (ref $otherrel_info->{cond} eq 'HASH') {
636 @othertestconds = ($otherrel_info->{cond});
638 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
639 @othertestconds = @{$otherrel_info->{cond}};
645 foreach my $othercond (@othertestconds) {
646 my @other_cond = keys(%$othercond);
647 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
648 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
649 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
650 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
651 $ret->{$otherrel} = $otherrel_info;
657 =head2 compare_relationship_keys
661 =item Arguments: $keys1, $keys2
665 Returns true if both sets of keynames are the same, false otherwise.
669 sub compare_relationship_keys {
670 my ($self, $keys1, $keys2) = @_;
672 # Make sure every keys1 is in keys2
674 foreach my $key (@$keys1) {
676 foreach my $prim (@$keys2) {
685 # Make sure every key2 is in key1
687 foreach my $prim (@$keys2) {
689 foreach my $key (@$keys1) {
706 =item Arguments: $relation
710 Returns the join structure required for the related result source.
715 my ($self, $join, $alias, $seen, $force_left) = @_;
717 $force_left ||= { force => 0 };
718 if (ref $join eq 'ARRAY') {
719 return map { $self->resolve_join($_, $alias, $seen) } @$join;
720 } elsif (ref $join eq 'HASH') {
723 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
724 local $force_left->{force};
726 $self->resolve_join($_, $alias, $seen, $force_left),
727 $self->related_source($_)->resolve_join(
728 $join->{$_}, $as, $seen, $force_left
732 } elsif (ref $join) {
733 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
735 my $count = ++$seen->{$join};
736 #use Data::Dumper; warn Dumper($seen);
737 my $as = ($count > 1 ? "${join}_${count}" : $join);
738 my $rel_info = $self->relationship_info($join);
739 $self->throw_exception("No such relationship ${join}") unless $rel_info;
741 if ($force_left->{force}) {
744 $type = $rel_info->{attrs}{join_type} || '';
745 $force_left->{force} = 1 if lc($type) eq 'left';
747 return [ { $as => $self->related_source($join)->from,
748 -join_type => $type },
749 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
753 =head2 resolve_condition
757 =item Arguments: $cond, $as, $alias|$object
761 Resolves the passed condition to a concrete query fragment. If given an alias,
762 returns a join condition; if given an object, inverts that object to produce
763 a related conditional from that object.
767 sub resolve_condition {
768 my ($self, $cond, $as, $for) = @_;
770 if (ref $cond eq 'HASH') {
772 foreach my $k (keys %{$cond}) {
774 # XXX should probably check these are valid columns
775 $k =~ s/^foreign\.// ||
776 $self->throw_exception("Invalid rel cond key ${k}");
778 $self->throw_exception("Invalid rel cond val ${v}");
779 if (ref $for) { # Object
780 #warn "$self $k $for $v";
781 $ret{$k} = $for->get_column($v);
783 } elsif (!defined $for) { # undef, i.e. "no object"
785 } elsif (ref $as eq 'HASH') { # reverse hashref
786 $ret{$v} = $as->{$k};
787 } elsif (ref $as) { # reverse object
788 $ret{$v} = $as->get_column($k);
789 } elsif (!defined $as) { # undef, i.e. "no reverse object"
792 $ret{"${as}.${k}"} = "${for}.${v}";
796 } elsif (ref $cond eq 'ARRAY') {
797 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
799 die("Can't handle this yet :(");
803 =head2 resolve_prefetch
807 =item Arguments: hashref/arrayref/scalar
811 Accepts one or more relationships for the current source and returns an
812 array of column names for each of those relationships. Column names are
813 prefixed relative to the current source, in accordance with where they appear
814 in the supplied relationships. Examples:
816 my $source = $schema->resultset('Tag')->source;
817 @columns = $source->resolve_prefetch( { cd => 'artist' } );
825 # 'cd.artist.artistid',
829 @columns = $source->resolve_prefetch( qw[/ cd /] );
839 $source = $schema->resultset('CD')->source;
840 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
846 # 'producer.producerid',
852 sub resolve_prefetch {
853 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
855 #$alias ||= $self->name;
856 #warn $alias, Dumper $pre;
857 if( ref $pre eq 'ARRAY' ) {
859 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
862 elsif( ref $pre eq 'HASH' ) {
865 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
866 $self->related_source($_)->resolve_prefetch(
867 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
873 $self->throw_exception(
874 "don't know how to resolve prefetch reftype ".ref($pre));
877 my $count = ++$seen->{$pre};
878 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
879 my $rel_info = $self->relationship_info( $pre );
880 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
882 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
883 my $rel_source = $self->related_source($pre);
885 if (exists $rel_info->{attrs}{accessor}
886 && $rel_info->{attrs}{accessor} eq 'multi') {
887 $self->throw_exception(
888 "Can't prefetch has_many ${pre} (join cond too complex)")
889 unless ref($rel_info->{cond}) eq 'HASH';
890 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
891 # values %{$rel_info->{cond}};
892 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
893 # action at a distance. prepending the '.' allows simpler code
894 # in ResultSet->_collapse_result
895 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
896 keys %{$rel_info->{cond}};
897 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
898 ? @{$rel_info->{attrs}{order_by}}
899 : (defined $rel_info->{attrs}{order_by}
900 ? ($rel_info->{attrs}{order_by})
902 push(@$order, map { "${as}.$_" } (@key, @ord));
905 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
906 $rel_source->columns;
907 #warn $alias, Dumper (\@ret);
912 =head2 related_source
916 =item Arguments: $relname
920 Returns the result source object for the given relationship.
925 my ($self, $rel) = @_;
926 if( !$self->has_relationship( $rel ) ) {
927 $self->throw_exception("No such relationship '$rel'");
929 return $self->schema->source($self->relationship_info($rel)->{source});
936 =item Arguments: $relname
940 Returns the class name for objects in the given relationship.
945 my ($self, $rel) = @_;
946 if( !$self->has_relationship( $rel ) ) {
947 $self->throw_exception("No such relationship '$rel'");
949 return $self->schema->class($self->relationship_info($rel)->{source});
954 Returns a resultset for the given source. This will initially be created
957 $self->resultset_class->new($self, $self->resultset_attributes)
959 but is cached from then on unless resultset_class changes.
961 =head2 resultset_class
963 ` package My::ResultSetClass;
964 use base 'DBIx::Class::ResultSet';
967 $source->resultset_class('My::ResultSet::Class');
969 Set the class of the resultset, this is useful if you want to create your
970 own resultset methods. Create your own class derived from
971 L<DBIx::Class::ResultSet>, and set it here.
973 =head2 resultset_attributes
975 $source->resultset_attributes({ order_by => [ 'id' ] });
977 Specify here any attributes you wish to pass to your specialised
978 resultset. For a full list of these, please see
979 L<DBIx::Class::ResultSet/ATTRIBUTES>.
985 $self->throw_exception(
986 'resultset does not take any arguments. If you want another resultset, '.
987 'call it on the schema instead.'
990 return $self->resultset_class->new(
993 %{$self->{resultset_attributes}},
994 %{$self->schema->default_resultset_attributes}
1003 =item Arguments: $source_name
1007 Set the name of the result source when it is loaded into a schema.
1008 This is usefull if you want to refer to a result source by a name other than
1011 package ArchivedBooks;
1012 use base qw/DBIx::Class/;
1013 __PACKAGE__->table('books_archive');
1014 __PACKAGE__->source_name('Books');
1016 # from your schema...
1017 $schema->resultset('Books')->find(1);
1021 Obtain a new handle to this source. Returns an instance of a
1022 L<DBIx::Class::ResultSourceHandle>.
1027 return new DBIx::Class::ResultSourceHandle({
1028 schema => $_[0]->schema,
1029 source_moniker => $_[0]->source_name
1033 =head2 throw_exception
1035 See L<DBIx::Class::Schema/"throw_exception">.
1039 sub throw_exception {
1041 if (defined $self->schema) {
1042 $self->schema->throw_exception(@_);
1050 Matt S. Trout <mst@shadowcatsystems.co.uk>
1054 You may distribute this code under the same terms as Perl itself.