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 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.
226 __PACKAGE__->column_info_from_storage(1);
230 my @column_names = $obj->columns;
232 Returns all column names in the order they were declared to add_columns.
238 $self->throw_exception(
239 "columns() is a read-only accessor, did you mean add_columns()?"
241 return @{$self->{_ordered_columns}||[]};
244 =head2 remove_columns
246 $table->remove_columns(qw/col1 col2 col3/);
248 Removes columns from the result source.
252 $table->remove_column('col');
254 Convenience alias to remove_columns.
259 my ($self, @cols) = @_;
261 return unless $self->_ordered_columns;
263 my $columns = $self->_columns;
266 foreach my $col (@{$self->_ordered_columns}) {
267 push @remaining, $col unless grep(/$col/, @cols);
271 delete $columns->{$_};
274 $self->_ordered_columns(\@remaining);
277 *remove_column = \&remove_columns;
279 =head2 set_primary_key
283 =item Arguments: @cols
287 Defines one or more columns as primary key for this source. Should be
288 called after C<add_columns>.
290 Additionally, defines a unique constraint named C<primary>.
292 The primary key columns are used by L<DBIx::Class::PK::Auto> to
293 retrieve automatically created values from the database.
297 sub set_primary_key {
298 my ($self, @cols) = @_;
299 # check if primary key columns are valid columns
300 foreach my $col (@cols) {
301 $self->throw_exception("No such column $col on table " . $self->name)
302 unless $self->has_column($col);
304 $self->_primaries(\@cols);
306 $self->add_unique_constraint(primary => \@cols);
309 =head2 primary_columns
311 Read-only accessor which returns the list of primary keys.
315 sub primary_columns {
316 return @{shift->_primaries||[]};
319 =head2 add_unique_constraint
321 Declare a unique constraint on this source. Call once for each unique
324 # For UNIQUE (column1, column2)
325 __PACKAGE__->add_unique_constraint(
326 constraint_name => [ qw/column1 column2/ ],
329 Alternatively, you can specify only the columns:
331 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
333 This will result in a unique constraint named C<table_column1_column2>, where
334 C<table> is replaced with the table name.
336 Unique constraints are used, for example, when you call
337 L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
341 sub add_unique_constraint {
346 $name ||= $self->name_unique_constraint($cols);
348 foreach my $col (@$cols) {
349 $self->throw_exception("No such column $col on table " . $self->name)
350 unless $self->has_column($col);
353 my %unique_constraints = $self->unique_constraints;
354 $unique_constraints{$name} = $cols;
355 $self->_unique_constraints(\%unique_constraints);
358 =head2 name_unique_constraint
360 Return a name for a unique constraint containing the specified columns. These
361 names consist of the table name and each column name, separated by underscores.
363 For example, a constraint on a table named C<cd> containing the columns
364 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
368 sub name_unique_constraint {
369 my ($self, $cols) = @_;
371 return join '_', $self->name, @$cols;
374 =head2 unique_constraints
376 Read-only accessor which returns the list of unique constraints on this source.
380 sub unique_constraints {
381 return %{shift->_unique_constraints||{}};
384 =head2 unique_constraint_names
386 Returns the list of unique constraint names defined on this source.
390 sub unique_constraint_names {
393 my %unique_constraints = $self->unique_constraints;
395 return keys %unique_constraints;
398 =head2 unique_constraint_columns
400 Returns the list of columns that make up the specified unique constraint.
404 sub unique_constraint_columns {
405 my ($self, $constraint_name) = @_;
407 my %unique_constraints = $self->unique_constraints;
409 $self->throw_exception(
410 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
411 ) unless exists $unique_constraints{$constraint_name};
413 return @{ $unique_constraints{$constraint_name} };
418 Returns an expression of the source to be supplied to storage to specify
419 retrieval from this source. In the case of a database, the required FROM
424 Returns the L<DBIx::Class::Schema> object that this result source
429 Returns the storage handle for the current schema.
431 See also: L<DBIx::Class::Storage>
435 sub storage { shift->schema->storage; }
437 =head2 add_relationship
439 $source->add_relationship('relname', 'related_source', $cond, $attrs);
441 The relationship name can be arbitrary, but must be unique for each
442 relationship attached to this result source. 'related_source' should
443 be the name with which the related result source was registered with
444 the current schema. For example:
446 $schema->source('Book')->add_relationship('reviews', 'Review', {
447 'foreign.book_id' => 'self.id',
450 The condition C<$cond> needs to be an L<SQL::Abstract>-style
451 representation of the join between the tables. For example, if you're
452 creating a rel from Author to Book,
454 { 'foreign.author_id' => 'self.id' }
456 will result in the JOIN clause
458 author me JOIN book foreign ON foreign.author_id = me.id
460 You can specify as many foreign => self mappings as necessary.
462 Valid attributes are as follows:
468 Explicitly specifies the type of join to use in the relationship. Any
469 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
470 the SQL command immediately before C<JOIN>.
474 An arrayref containing a list of accessors in the foreign class to proxy in
475 the main class. If, for example, you do the following:
477 CD->might_have(liner_notes => 'LinerNotes', undef, {
478 proxy => [ qw/notes/ ],
481 Then, assuming LinerNotes has an accessor named notes, you can do:
483 my $cd = CD->find(1);
484 # set notes -- LinerNotes object is created if it doesn't exist
485 $cd->notes('Notes go here');
489 Specifies the type of accessor that should be created for the
490 relationship. Valid values are C<single> (for when there is only a single
491 related object), C<multi> (when there can be many), and C<filter> (for
492 when there is a single related object, but you also want the relationship
493 accessor to double as a column accessor). For C<multi> accessors, an
494 add_to_* method is also created, which calls C<create_related> for the
501 sub add_relationship {
502 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
503 $self->throw_exception("Can't create relationship without join condition")
507 my %rels = %{ $self->_relationships };
508 $rels{$rel} = { class => $f_source_name,
509 source => $f_source_name,
512 $self->_relationships(\%rels);
516 # XXX disabled. doesn't work properly currently. skip in tests.
518 my $f_source = $self->schema->source($f_source_name);
520 $self->ensure_class_loaded($f_source_name);
521 $f_source = $f_source_name->result_source;
522 #my $s_class = ref($self->schema);
523 #$f_source_name =~ m/^${s_class}::(.*)$/;
524 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
525 #$f_source = $self->schema->source($f_source_name);
527 return unless $f_source; # Can't test rel without f_source
529 eval { $self->resolve_join($rel, 'me') };
531 if ($@) { # If the resolve failed, back out and re-throw the error
532 delete $rels{$rel}; #
533 $self->_relationships(\%rels);
534 $self->throw_exception("Error creating relationship $rel: $@");
541 Returns all relationship names for this source.
546 return keys %{shift->_relationships};
549 =head2 relationship_info
553 =item Arguments: $relname
557 Returns a hash of relationship information for the specified relationship
562 sub relationship_info {
563 my ($self, $rel) = @_;
564 return $self->_relationships->{$rel};
567 =head2 has_relationship
571 =item Arguments: $rel
575 Returns true if the source has a relationship of this name, false otherwise.
579 sub has_relationship {
580 my ($self, $rel) = @_;
581 return exists $self->_relationships->{$rel};
584 =head2 reverse_relationship_info
588 =item Arguments: $relname
592 Returns an array of hash references of relationship information for
593 the other side of the specified relationship name.
597 sub reverse_relationship_info {
598 my ($self, $rel) = @_;
599 my $rel_info = $self->relationship_info($rel);
602 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
604 my @cond = keys(%{$rel_info->{cond}});
605 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
606 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
608 # Get the related result source for this relationship
609 my $othertable = $self->related_source($rel);
611 # Get all the relationships for that source that related to this source
612 # whose foreign column set are our self columns on $rel and whose self
613 # columns are our foreign columns on $rel.
614 my @otherrels = $othertable->relationships();
615 my $otherrelationship;
616 foreach my $otherrel (@otherrels) {
617 my $otherrel_info = $othertable->relationship_info($otherrel);
619 my $back = $othertable->related_source($otherrel);
620 next unless $back->name eq $self->name;
624 if (ref $otherrel_info->{cond} eq 'HASH') {
625 @othertestconds = ($otherrel_info->{cond});
627 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
628 @othertestconds = @{$otherrel_info->{cond}};
634 foreach my $othercond (@othertestconds) {
635 my @other_cond = keys(%$othercond);
636 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
637 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
638 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
639 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
640 $ret->{$otherrel} = $otherrel_info;
646 =head2 compare_relationship_keys
650 =item Arguments: $keys1, $keys2
654 Returns true if both sets of keynames are the same, false otherwise.
658 sub compare_relationship_keys {
659 my ($self, $keys1, $keys2) = @_;
661 # Make sure every keys1 is in keys2
663 foreach my $key (@$keys1) {
665 foreach my $prim (@$keys2) {
674 # Make sure every key2 is in key1
676 foreach my $prim (@$keys2) {
678 foreach my $key (@$keys1) {
695 =item Arguments: $relation
699 Returns the join structure required for the related result source.
704 my ($self, $join, $alias, $seen) = @_;
706 if (ref $join eq 'ARRAY') {
707 return map { $self->resolve_join($_, $alias, $seen) } @$join;
708 } elsif (ref $join eq 'HASH') {
711 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
712 ($self->resolve_join($_, $alias, $seen),
713 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
715 } elsif (ref $join) {
716 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
718 my $count = ++$seen->{$join};
719 #use Data::Dumper; warn Dumper($seen);
720 my $as = ($count > 1 ? "${join}_${count}" : $join);
721 my $rel_info = $self->relationship_info($join);
722 $self->throw_exception("No such relationship ${join}") unless $rel_info;
723 my $type = $rel_info->{attrs}{join_type} || '';
724 return [ { $as => $self->related_source($join)->from,
725 -join_type => $type },
726 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
730 =head2 resolve_condition
734 =item Arguments: $cond, $as, $alias|$object
738 Resolves the passed condition to a concrete query fragment. If given an alias,
739 returns a join condition; if given an object, inverts that object to produce
740 a related conditional from that object.
744 sub resolve_condition {
745 my ($self, $cond, $as, $for) = @_;
747 if (ref $cond eq 'HASH') {
749 foreach my $k (keys %{$cond}) {
751 # XXX should probably check these are valid columns
752 $k =~ s/^foreign\.// ||
753 $self->throw_exception("Invalid rel cond key ${k}");
755 $self->throw_exception("Invalid rel cond val ${v}");
756 if (ref $for) { # Object
757 #warn "$self $k $for $v";
758 $ret{$k} = $for->get_column($v);
760 } elsif (!defined $for) { # undef, i.e. "no object"
762 } elsif (ref $as) { # reverse object
763 $ret{$v} = $as->get_column($k);
764 } elsif (!defined $as) { # undef, i.e. "no reverse object"
767 $ret{"${as}.${k}"} = "${for}.${v}";
771 } elsif (ref $cond eq 'ARRAY') {
772 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
774 die("Can't handle this yet :(");
778 =head2 resolve_prefetch
782 =item Arguments: hashref/arrayref/scalar
786 Accepts one or more relationships for the current source and returns an
787 array of column names for each of those relationships. Column names are
788 prefixed relative to the current source, in accordance with where they appear
789 in the supplied relationships. Examples:
791 my $source = $schema->resultset('Tag')->source;
792 @columns = $source->resolve_prefetch( { cd => 'artist' } );
800 # 'cd.artist.artistid',
804 @columns = $source->resolve_prefetch( qw[/ cd /] );
814 $source = $schema->resultset('CD')->source;
815 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
821 # 'producer.producerid',
827 sub resolve_prefetch {
828 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
830 #$alias ||= $self->name;
831 #warn $alias, Dumper $pre;
832 if( ref $pre eq 'ARRAY' ) {
834 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
837 elsif( ref $pre eq 'HASH' ) {
840 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
841 $self->related_source($_)->resolve_prefetch(
842 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
848 $self->throw_exception(
849 "don't know how to resolve prefetch reftype ".ref($pre));
852 my $count = ++$seen->{$pre};
853 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
854 my $rel_info = $self->relationship_info( $pre );
855 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
857 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
858 my $rel_source = $self->related_source($pre);
860 if (exists $rel_info->{attrs}{accessor}
861 && $rel_info->{attrs}{accessor} eq 'multi') {
862 $self->throw_exception(
863 "Can't prefetch has_many ${pre} (join cond too complex)")
864 unless ref($rel_info->{cond}) eq 'HASH';
865 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
866 keys %{$rel_info->{cond}};
867 $collapse->{"${as_prefix}${pre}"} = \@key;
868 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
869 ? @{$rel_info->{attrs}{order_by}}
870 : (defined $rel_info->{attrs}{order_by}
871 ? ($rel_info->{attrs}{order_by})
873 push(@$order, map { "${as}.$_" } (@key, @ord));
876 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
877 $rel_source->columns;
878 #warn $alias, Dumper (\@ret);
883 =head2 related_source
887 =item Arguments: $relname
891 Returns the result source object for the given relationship.
896 my ($self, $rel) = @_;
897 if( !$self->has_relationship( $rel ) ) {
898 $self->throw_exception("No such relationship '$rel'");
900 return $self->schema->source($self->relationship_info($rel)->{source});
907 =item Arguments: $relname
911 Returns the class name for objects in the given relationship.
916 my ($self, $rel) = @_;
917 if( !$self->has_relationship( $rel ) ) {
918 $self->throw_exception("No such relationship '$rel'");
920 return $self->schema->class($self->relationship_info($rel)->{source});
925 Returns a resultset for the given source. This will initially be created
928 $self->resultset_class->new($self, $self->resultset_attributes)
930 but is cached from then on unless resultset_class changes.
932 =head2 resultset_class
934 Set the class of the resultset, this is useful if you want to create your
935 own resultset methods. Create your own class derived from
936 L<DBIx::Class::ResultSet>, and set it here.
938 =head2 resultset_attributes
940 Specify here any attributes you wish to pass to your specialised resultset.
946 $self->throw_exception(
947 'resultset does not take any arguments. If you want another resultset, '.
948 'call it on the schema instead.'
951 # disabled until we can figure out a way to do it without consistency issues
953 #return $self->{_resultset}
954 # if ref $self->{_resultset} eq $self->resultset_class;
955 #return $self->{_resultset} =
957 return $self->resultset_class->new(
958 $self, $self->{resultset_attributes}
966 =item Arguments: $source_name
970 Set the name of the result source when it is loaded into a schema.
971 This is usefull if you want to refer to a result source by a name other than
974 package ArchivedBooks;
975 use base qw/DBIx::Class/;
976 __PACKAGE__->table('books_archive');
977 __PACKAGE__->source_name('Books');
979 # from your schema...
980 $schema->resultset('Books')->find(1);
982 =head2 throw_exception
984 See L<DBIx::Class::Schema/"throw_exception">.
988 sub throw_exception {
990 if (defined $self->schema) {
991 $self->schema->throw_exception(@_);
999 Matt S. Trout <mst@shadowcatsystems.co.uk>
1003 You may distribute this code under the same terms as Perl itself.