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
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 = { %{$attrs || {}}, _resultset => undef };
53 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
54 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
55 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
56 $new->{_columns} = { %{$new->{_columns}||{}} };
57 $new->{_relationships} = { %{$new->{_relationships}||{}} };
58 $new->{name} ||= "!!NAME NOT SET!!";
59 $new->{_columns_info_loaded} ||= 0;
67 Stores a hashref of per-source metadata. No specific key names
68 have yet been standardized, the examples below are purely hypothetical
69 and don't actually accomplish anything on their own:
71 __PACKAGE__->source_info({
72 "_tablespace" => 'fast_disk_array_3',
73 "_engine" => 'InnoDB',
78 $table->add_columns(qw/col1 col2 col3/);
80 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
82 Adds columns to the result source. If supplied key => hashref pairs, uses
83 the hashref as the column_info for that column. Repeated calls of this
84 method will add more columns, not replace them.
86 The contents of the column_info are not set in stone. The following
87 keys are currently recognised/used by DBIx::Class:
93 Use this to set the name of the accessor for this column. If unset,
94 the name of the column will be used.
98 This contains the column type. It is automatically filled by the
99 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
100 L<DBIx::Class::Schema::Loader> module. If you do not enter a
101 data_type, DBIx::Class will attempt to retrieve it from the
102 database for you, using L<DBI>'s column_info method. The values of this
103 key are typically upper-cased.
105 Currently there is no standard set of values for the data_type. Use
106 whatever your database supports.
110 The length of your column, if it is a column type that can have a size
111 restriction. This is currently not used by DBIx::Class.
115 Set this to a true value for a columns that is allowed to contain
116 NULL values. This is currently not used by DBIx::Class.
118 =item is_auto_increment
120 Set this to a true value for a column whose value is somehow
121 automatically set. This is used to determine which columns to empty
122 when cloning objects using C<copy>.
126 Set this to a true value for a column that contains a key from a
127 foreign table. This is currently not used by DBIx::Class.
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 not used by DBIx::Class.
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
146 $table->add_column('col' => \%info?);
148 Convenience alias to add_columns.
153 my ($self, @cols) = @_;
154 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
157 my $columns = $self->_columns;
158 while (my $col = shift @cols) {
159 # If next entry is { ... } use that for the column info, if not
160 # use an empty hashref
161 my $column_info = ref $cols[0] ? shift(@cols) : {};
162 push(@added, $col) unless exists $columns->{$col};
163 $columns->{$col} = $column_info;
165 push @{ $self->_ordered_columns }, @added;
169 *add_column = \&add_columns;
173 if ($obj->has_column($col)) { ... }
175 Returns true if the source has a column of this name, false otherwise.
180 my ($self, $column) = @_;
181 return exists $self->_columns->{$column};
186 my $info = $obj->column_info($col);
188 Returns the column metadata hashref for a column. See the description
189 of add_column for information on the contents of the hashref.
194 my ($self, $column) = @_;
195 $self->throw_exception("No such column $column")
196 unless exists $self->_columns->{$column};
197 #warn $self->{_columns_info_loaded}, "\n";
198 if ( ! $self->_columns->{$column}{data_type}
199 and $self->column_info_from_storage
200 and ! $self->{_columns_info_loaded}
201 and $self->schema and $self->storage )
203 $self->{_columns_info_loaded}++;
206 # eval for the case of storage without table
207 eval { $info = $self->storage->columns_info_for( $self->from ) };
209 for my $realcol ( keys %{$info} ) {
210 $lc_info->{lc $realcol} = $info->{$realcol};
212 foreach my $col ( keys %{$self->_columns} ) {
213 $self->_columns->{$col} = { %{ $self->_columns->{$col}}, %{$info->{$col} || $lc_info->{lc $col}} };
217 return $self->_columns->{$column};
220 =head2 load_column_info_from_storage
222 Enables the on-demand automatic loading of the above column
223 metadata from storage as neccesary. This is *deprecated*, and
224 should not be used. It will be removed before 1.0.
228 sub load_column_info_from_storage { shift->column_info_from_storage(1) }
232 my @column_names = $obj->columns;
234 Returns all column names in the order they were declared to add_columns.
240 $self->throw_exception(
241 "columns() is a read-only accessor, did you mean add_columns()?"
243 return @{$self->{_ordered_columns}||[]};
246 =head2 remove_columns
248 $table->remove_columns(qw/col1 col2 col3/);
250 Removes columns from the result source.
254 $table->remove_column('col');
256 Convenience alias to remove_columns.
261 my ($self, @cols) = @_;
263 return unless $self->_ordered_columns;
265 my $columns = $self->_columns;
268 foreach my $col (@{$self->_ordered_columns}) {
269 push @remaining, $col unless grep(/$col/, @cols);
273 delete $columns->{$_};
276 $self->_ordered_columns(\@remaining);
279 *remove_column = \&remove_columns;
281 =head2 set_primary_key
285 =item Arguments: @cols
289 Defines one or more columns as primary key for this source. Should be
290 called after C<add_columns>.
292 Additionally, defines a unique constraint named C<primary>.
294 The primary key columns are used by L<DBIx::Class::PK::Auto> to
295 retrieve automatically created values from the database.
299 sub set_primary_key {
300 my ($self, @cols) = @_;
301 # check if primary key columns are valid columns
302 foreach my $col (@cols) {
303 $self->throw_exception("No such column $col on table " . $self->name)
304 unless $self->has_column($col);
306 $self->_primaries(\@cols);
308 $self->add_unique_constraint(primary => \@cols);
311 =head2 primary_columns
313 Read-only accessor which returns the list of primary keys.
317 sub primary_columns {
318 return @{shift->_primaries||[]};
321 =head2 add_unique_constraint
323 Declare a unique constraint on this source. Call once for each unique
326 # For UNIQUE (column1, column2)
327 __PACKAGE__->add_unique_constraint(
328 constraint_name => [ qw/column1 column2/ ],
331 Alternatively, you can specify only the columns:
333 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
335 This will result in a unique constraint named C<table_column1_column2>, where
336 C<table> is replaced with the table name.
338 Unique constraints are used, for example, when you call
339 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
343 sub add_unique_constraint {
348 $name ||= $self->name_unique_constraint($cols);
350 foreach my $col (@$cols) {
351 $self->throw_exception("No such column $col on table " . $self->name)
352 unless $self->has_column($col);
355 my %unique_constraints = $self->unique_constraints;
356 $unique_constraints{$name} = $cols;
357 $self->_unique_constraints(\%unique_constraints);
360 =head2 name_unique_constraint
362 Return a name for a unique constraint containing the specified columns. These
363 names consist of the table name and each column name, separated by underscores.
365 For example, a constraint on a table named C<cd> containing the columns
366 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
370 sub name_unique_constraint {
371 my ($self, $cols) = @_;
373 return join '_', $self->name, @$cols;
376 =head2 unique_constraints
378 Read-only accessor which returns the list of unique constraints on this source.
382 sub unique_constraints {
383 return %{shift->_unique_constraints||{}};
386 =head2 unique_constraint_names
388 Returns the list of unique constraint names defined on this source.
392 sub unique_constraint_names {
395 my %unique_constraints = $self->unique_constraints;
397 return keys %unique_constraints;
400 =head2 unique_constraint_columns
402 Returns the list of columns that make up the specified unique constraint.
406 sub unique_constraint_columns {
407 my ($self, $constraint_name) = @_;
409 my %unique_constraints = $self->unique_constraints;
411 $self->throw_exception(
412 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
413 ) unless exists $unique_constraints{$constraint_name};
415 return @{ $unique_constraints{$constraint_name} };
420 Returns an expression of the source to be supplied to storage to specify
421 retrieval from this source. In the case of a database, the required FROM
426 Returns the L<DBIx::Class::Schema> object that this result source
431 Returns the storage handle for the current schema.
433 See also: L<DBIx::Class::Storage>
437 sub storage { shift->schema->storage; }
439 =head2 add_relationship
441 $source->add_relationship('relname', 'related_source', $cond, $attrs);
443 The relationship name can be arbitrary, but must be unique for each
444 relationship attached to this result source. 'related_source' should
445 be the name with which the related result source was registered with
446 the current schema. For example:
448 $schema->source('Book')->add_relationship('reviews', 'Review', {
449 'foreign.book_id' => 'self.id',
452 The condition C<$cond> needs to be an L<SQL::Abstract>-style
453 representation of the join between the tables. For example, if you're
454 creating a rel from Author to Book,
456 { 'foreign.author_id' => 'self.id' }
458 will result in the JOIN clause
460 author me JOIN book foreign ON foreign.author_id = me.id
462 You can specify as many foreign => self mappings as necessary.
464 Valid attributes are as follows:
470 Explicitly specifies the type of join to use in the relationship. Any
471 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
472 the SQL command immediately before C<JOIN>.
476 An arrayref containing a list of accessors in the foreign class to proxy in
477 the main class. If, for example, you do the following:
479 CD->might_have(liner_notes => 'LinerNotes', undef, {
480 proxy => [ qw/notes/ ],
483 Then, assuming LinerNotes has an accessor named notes, you can do:
485 my $cd = CD->find(1);
486 # set notes -- LinerNotes object is created if it doesn't exist
487 $cd->notes('Notes go here');
491 Specifies the type of accessor that should be created for the
492 relationship. Valid values are C<single> (for when there is only a single
493 related object), C<multi> (when there can be many), and C<filter> (for
494 when there is a single related object, but you also want the relationship
495 accessor to double as a column accessor). For C<multi> accessors, an
496 add_to_* method is also created, which calls C<create_related> for the
503 sub add_relationship {
504 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
505 $self->throw_exception("Can't create relationship without join condition")
509 my %rels = %{ $self->_relationships };
510 $rels{$rel} = { class => $f_source_name,
511 source => $f_source_name,
514 $self->_relationships(\%rels);
518 # XXX disabled. doesn't work properly currently. skip in tests.
520 my $f_source = $self->schema->source($f_source_name);
522 $self->ensure_class_loaded($f_source_name);
523 $f_source = $f_source_name->result_source;
524 #my $s_class = ref($self->schema);
525 #$f_source_name =~ m/^${s_class}::(.*)$/;
526 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
527 #$f_source = $self->schema->source($f_source_name);
529 return unless $f_source; # Can't test rel without f_source
531 eval { $self->resolve_join($rel, 'me') };
533 if ($@) { # If the resolve failed, back out and re-throw the error
534 delete $rels{$rel}; #
535 $self->_relationships(\%rels);
536 $self->throw_exception("Error creating relationship $rel: $@");
543 Returns all relationship names for this source.
548 return keys %{shift->_relationships};
551 =head2 relationship_info
555 =item Arguments: $relname
559 Returns a hash of relationship information for the specified relationship
564 sub relationship_info {
565 my ($self, $rel) = @_;
566 return $self->_relationships->{$rel};
569 =head2 has_relationship
573 =item Arguments: $rel
577 Returns true if the source has a relationship of this name, false otherwise.
581 sub has_relationship {
582 my ($self, $rel) = @_;
583 return exists $self->_relationships->{$rel};
586 =head2 reverse_relationship_info
590 =item Arguments: $relname
594 Returns an array of hash references of relationship information for
595 the other side of the specified relationship name.
599 sub reverse_relationship_info {
600 my ($self, $rel) = @_;
601 my $rel_info = $self->relationship_info($rel);
604 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
606 my @cond = keys(%{$rel_info->{cond}});
607 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
608 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
610 # Get the related result source for this relationship
611 my $othertable = $self->related_source($rel);
613 # Get all the relationships for that source that related to this source
614 # whose foreign column set are our self columns on $rel and whose self
615 # columns are our foreign columns on $rel.
616 my @otherrels = $othertable->relationships();
617 my $otherrelationship;
618 foreach my $otherrel (@otherrels) {
619 my $otherrel_info = $othertable->relationship_info($otherrel);
621 my $back = $othertable->related_source($otherrel);
622 next unless $back->name eq $self->name;
626 if (ref $otherrel_info->{cond} eq 'HASH') {
627 @othertestconds = ($otherrel_info->{cond});
629 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
630 @othertestconds = @{$otherrel_info->{cond}};
636 foreach my $othercond (@othertestconds) {
637 my @other_cond = keys(%$othercond);
638 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
639 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
640 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
641 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
642 $ret->{$otherrel} = $otherrel_info;
648 =head2 compare_relationship_keys
652 =item Arguments: $keys1, $keys2
656 Returns true if both sets of keynames are the same, false otherwise.
660 sub compare_relationship_keys {
661 my ($self, $keys1, $keys2) = @_;
663 # Make sure every keys1 is in keys2
665 foreach my $key (@$keys1) {
667 foreach my $prim (@$keys2) {
676 # Make sure every key2 is in key1
678 foreach my $prim (@$keys2) {
680 foreach my $key (@$keys1) {
697 =item Arguments: $relation
701 Returns the join structure required for the related result source.
706 my ($self, $join, $alias, $seen) = @_;
708 if (ref $join eq 'ARRAY') {
709 return map { $self->resolve_join($_, $alias, $seen) } @$join;
710 } elsif (ref $join eq 'HASH') {
713 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
714 ($self->resolve_join($_, $alias, $seen),
715 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
717 } elsif (ref $join) {
718 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
720 my $count = ++$seen->{$join};
721 #use Data::Dumper; warn Dumper($seen);
722 my $as = ($count > 1 ? "${join}_${count}" : $join);
723 my $rel_info = $self->relationship_info($join);
724 $self->throw_exception("No such relationship ${join}") unless $rel_info;
725 my $type = $rel_info->{attrs}{join_type} || '';
726 return [ { $as => $self->related_source($join)->from,
727 -join_type => $type },
728 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
732 =head2 resolve_condition
736 =item Arguments: $cond, $as, $alias|$object
740 Resolves the passed condition to a concrete query fragment. If given an alias,
741 returns a join condition; if given an object, inverts that object to produce
742 a related conditional from that object.
746 sub resolve_condition {
747 my ($self, $cond, $as, $for) = @_;
749 if (ref $cond eq 'HASH') {
751 foreach my $k (keys %{$cond}) {
753 # XXX should probably check these are valid columns
754 $k =~ s/^foreign\.// ||
755 $self->throw_exception("Invalid rel cond key ${k}");
757 $self->throw_exception("Invalid rel cond val ${v}");
758 if (ref $for) { # Object
759 #warn "$self $k $for $v";
760 $ret{$k} = $for->get_column($v);
762 } elsif (!defined $for) { # undef, i.e. "no object"
764 } elsif (ref $as) { # reverse object
765 $ret{$v} = $as->get_column($k);
766 } elsif (!defined $as) { # undef, i.e. "no reverse object"
769 $ret{"${as}.${k}"} = "${for}.${v}";
773 } elsif (ref $cond eq 'ARRAY') {
774 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
776 die("Can't handle this yet :(");
780 =head2 resolve_prefetch
784 =item Arguments: hashref/arrayref/scalar
788 Accepts one or more relationships for the current source and returns an
789 array of column names for each of those relationships. Column names are
790 prefixed relative to the current source, in accordance with where they appear
791 in the supplied relationships. Examples:
793 my $source = $schema->resultset('Tag')->source;
794 @columns = $source->resolve_prefetch( { cd => 'artist' } );
802 # 'cd.artist.artistid',
806 @columns = $source->resolve_prefetch( qw[/ cd /] );
816 $source = $schema->resultset('CD')->source;
817 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
823 # 'producer.producerid',
829 sub resolve_prefetch {
830 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
832 #$alias ||= $self->name;
833 #warn $alias, Dumper $pre;
834 if( ref $pre eq 'ARRAY' ) {
836 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
839 elsif( ref $pre eq 'HASH' ) {
842 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
843 $self->related_source($_)->resolve_prefetch(
844 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
850 $self->throw_exception(
851 "don't know how to resolve prefetch reftype ".ref($pre));
854 my $count = ++$seen->{$pre};
855 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
856 my $rel_info = $self->relationship_info( $pre );
857 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
859 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
860 my $rel_source = $self->related_source($pre);
862 if (exists $rel_info->{attrs}{accessor}
863 && $rel_info->{attrs}{accessor} eq 'multi') {
864 $self->throw_exception(
865 "Can't prefetch has_many ${pre} (join cond too complex)")
866 unless ref($rel_info->{cond}) eq 'HASH';
867 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
868 keys %{$rel_info->{cond}};
869 $collapse->{"${as_prefix}${pre}"} = \@key;
870 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
871 ? @{$rel_info->{attrs}{order_by}}
872 : (defined $rel_info->{attrs}{order_by}
873 ? ($rel_info->{attrs}{order_by})
875 push(@$order, map { "${as}.$_" } (@key, @ord));
878 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
879 $rel_source->columns;
880 #warn $alias, Dumper (\@ret);
885 =head2 related_source
889 =item Arguments: $relname
893 Returns the result source object for the given relationship.
898 my ($self, $rel) = @_;
899 if( !$self->has_relationship( $rel ) ) {
900 $self->throw_exception("No such relationship '$rel'");
902 return $self->schema->source($self->relationship_info($rel)->{source});
909 =item Arguments: $relname
913 Returns the class name for objects in the given relationship.
918 my ($self, $rel) = @_;
919 if( !$self->has_relationship( $rel ) ) {
920 $self->throw_exception("No such relationship '$rel'");
922 return $self->schema->class($self->relationship_info($rel)->{source});
927 Returns a resultset for the given source. This will initially be created
930 $self->resultset_class->new($self, $self->resultset_attributes)
932 but is cached from then on unless resultset_class changes.
934 =head2 resultset_class
936 Set the class of the resultset, this is useful if you want to create your
937 own resultset methods. Create your own class derived from
938 L<DBIx::Class::ResultSet>, and set it here.
940 =head2 resultset_attributes
942 Specify here any attributes you wish to pass to your specialised resultset.
948 $self->throw_exception(
949 'resultset does not take any arguments. If you want another resultset, '.
950 'call it on the schema instead.'
953 # disabled until we can figure out a way to do it without consistency issues
955 #return $self->{_resultset}
956 # if ref $self->{_resultset} eq $self->resultset_class;
957 #return $self->{_resultset} =
959 return $self->resultset_class->new(
960 $self, $self->{resultset_attributes}
968 =item Arguments: $source_name
972 Set the name of the result source when it is loaded into a schema.
973 This is usefull if you want to refer to a result source by a name other than
976 package ArchivedBooks;
977 use base qw/DBIx::Class/;
978 __PACKAGE__->table('books_archive');
979 __PACKAGE__->source_name('Books');
981 # from your schema...
982 $schema->resultset('Books')->find(1);
984 =head2 throw_exception
986 See L<DBIx::Class::Schema/"throw_exception">.
990 sub throw_exception {
992 if (defined $self->schema) {
993 $self->schema->throw_exception(@_);
1001 Matt S. Trout <mst@shadowcatsystems.co.uk>
1005 You may distribute this code under the same terms as Perl itself.