1 package DBIx::Class::ResultSource;
6 use DBIx::Class::ResultSet;
7 use Carp::Clan qw/^DBIx::Class/;
10 use Scalar::Util qw/weaken/;
12 use base qw/DBIx::Class/;
13 __PACKAGE__->load_components(qw/AccessorGroup/);
15 __PACKAGE__->mk_group_accessors('simple' =>
16 qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes schema from _relationships/);
17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/);
21 DBIx::Class::ResultSource - Result source object
27 A ResultSource is a component of a schema from which results can be directly
28 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
35 my ($class, $attrs) = @_;
36 $class = ref $class if ref $class;
37 my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
38 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
39 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
40 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
41 $new->{_columns} = { %{$new->{_columns}||{}} };
42 $new->{_relationships} = { %{$new->{_relationships}||{}} };
43 $new->{name} ||= "!!NAME NOT SET!!";
44 $new->{_columns_info_loaded} ||= 0;
50 $table->add_columns(qw/col1 col2 col3/);
52 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
54 Adds columns to the result source. If supplied key => hashref pairs uses
55 the hashref as the column_info for that column.
59 $table->add_column('col' => \%info?);
61 Convenience alias to add_columns
66 my ($self, @cols) = @_;
67 $self->_ordered_columns( \@cols )
68 if !$self->_ordered_columns;
70 my $columns = $self->_columns;
71 while (my $col = shift @cols) {
73 my $column_info = ref $cols[0] ? shift(@cols) : {};
74 # If next entry is { ... } use that for the column info, if not
75 # use an empty hashref
77 push(@added, $col) unless exists $columns->{$col};
79 $columns->{$col} = $column_info;
81 push @{ $self->_ordered_columns }, @added;
85 *add_column = \&add_columns;
89 if ($obj->has_column($col)) { ... }
91 Returns 1 if the source has a column of this name, 0 otherwise.
96 my ($self, $column) = @_;
97 return exists $self->_columns->{$column};
102 my $info = $obj->column_info($col);
104 Returns the column metadata hashref for a column.
109 my ($self, $column) = @_;
110 $self->throw_exception("No such column $column")
111 unless exists $self->_columns->{$column};
112 #warn $self->{_columns_info_loaded}, "\n";
113 if ( ! $self->_columns->{$column}->{data_type}
114 && ! $self->{_columns_info_loaded}
115 && $self->schema && $self->storage() ){
116 $self->{_columns_info_loaded}++;
118 ############ eval for the case of storage without table
120 $info = $self->storage->columns_info_for ( $self->from() );
123 for my $col ( keys %{$self->_columns} ){
124 for my $i ( keys %{$info->{$col}} ){
125 $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
130 return $self->_columns->{$column};
135 my @column_names = $obj->columns;
137 Returns all column names in the order they were declared to add_columns
143 $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
144 return @{$self->{_ordered_columns}||[]};
147 =head2 set_primary_key(@cols)
149 Defines one or more columns as primary key for this source. Should be
150 called after C<add_columns>.
152 Additionally, defines a unique constraint named C<primary>.
156 sub set_primary_key {
157 my ($self, @cols) = @_;
158 # check if primary key columns are valid columns
160 $self->throw_exception("No such column $_ on table ".$self->name)
161 unless $self->has_column($_);
163 $self->_primaries(\@cols);
165 $self->add_unique_constraint(primary => \@cols);
168 =head2 primary_columns
170 Read-only accessor which returns the list of primary keys.
174 sub primary_columns {
175 return @{shift->_primaries||[]};
178 =head2 add_unique_constraint
180 Declare a unique constraint on this source. Call once for each unique
183 # For e.g. UNIQUE (column1, column2)
184 __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
188 sub add_unique_constraint {
189 my ($self, $name, $cols) = @_;
192 $self->throw_exception("No such column $_ on table ".$self->name)
193 unless $self->has_column($_);
196 my %unique_constraints = $self->unique_constraints;
197 $unique_constraints{$name} = $cols;
198 $self->_unique_constraints(\%unique_constraints);
201 =head2 unique_constraints
203 Read-only accessor which returns the list of unique constraints on this source.
207 sub unique_constraints {
208 return %{shift->_unique_constraints||{}};
213 Returns an expression of the source to be supplied to storage to specify
214 retrieval from this source; in the case of a database the required FROM clause
221 Returns the storage handle for the current schema
225 sub storage { shift->schema->storage; }
227 =head2 add_relationship
229 $source->add_relationship('relname', 'related_source', $cond, $attrs);
231 The relation name can be arbitrary, but must be unique for each relationship
232 attached to this result source. 'related_source' should be the name with
233 which the related result source was registered with the current schema
234 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
236 The condition needs to be an SQL::Abstract-style representation of the join
237 between the tables. For example, if you're creating a rel from Foo to Bar,
239 { 'foreign.foo_id' => 'self.id' }
241 will result in the JOIN clause
243 foo me JOIN bar bar ON bar.foo_id = me.id
245 You can specify as many foreign => self mappings as necessary.
247 Valid attributes are as follows:
253 Explicitly specifies the type of join to use in the relationship. Any SQL
254 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
255 command immediately before C<JOIN>.
259 An arrayref containing a list of accessors in the foreign class to proxy in
260 the main class. If, for example, you do the following:
262 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
264 Then, assuming Bar has an accessor named margle, you can do:
266 my $obj = Foo->find(1);
267 $obj->margle(10); # set margle; Bar object is created if it doesn't exist
271 Specifies the type of accessor that should be created for the relationship.
272 Valid values are C<single> (for when there is only a single related object),
273 C<multi> (when there can be many), and C<filter> (for when there is a single
274 related object, but you also want the relationship accessor to double as
275 a column accessor). For C<multi> accessors, an add_to_* method is also
276 created, which calls C<create_related> for the relationship.
282 sub add_relationship {
283 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
284 $self->throw_exception("Can't create relationship without join condition") unless $cond;
287 my %rels = %{ $self->_relationships };
288 $rels{$rel} = { class => $f_source_name,
289 source => $f_source_name,
292 $self->_relationships(\%rels);
296 # XXX disabled. doesn't work properly currently. skip in tests.
298 my $f_source = $self->schema->source($f_source_name);
300 eval "require $f_source_name;";
302 die $@ unless $@ =~ /Can't locate/;
304 $f_source = $f_source_name->result_source;
305 #my $s_class = ref($self->schema);
306 #$f_source_name =~ m/^${s_class}::(.*)$/;
307 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
308 #$f_source = $self->schema->source($f_source_name);
310 return unless $f_source; # Can't test rel without f_source
312 eval { $self->resolve_join($rel, 'me') };
314 if ($@) { # If the resolve failed, back out and re-throw the error
315 delete $rels{$rel}; #
316 $self->_relationships(\%rels);
317 $self->throw_exception("Error creating relationship $rel: $@");
322 =head2 relationships()
324 Returns all valid relationship names for this source
329 return keys %{shift->_relationships};
332 =head2 relationship_info($relname)
334 Returns the relationship information for the specified relationship name
338 sub relationship_info {
339 my ($self, $rel) = @_;
340 return $self->_relationships->{$rel};
343 =head2 has_relationship($rel)
345 Returns 1 if the source has a relationship of this name, 0 otherwise.
349 sub has_relationship {
350 my ($self, $rel) = @_;
351 return exists $self->_relationships->{$rel};
354 =head2 resolve_join($relation)
356 Returns the join structure required for the related result source
361 my ($self, $join, $alias, $seen) = @_;
363 if (ref $join eq 'ARRAY') {
364 return map { $self->resolve_join($_, $alias, $seen) } @$join;
365 } elsif (ref $join eq 'HASH') {
368 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
369 ($self->resolve_join($_, $alias, $seen),
370 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
372 } elsif (ref $join) {
373 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
375 my $count = ++$seen->{$join};
376 #use Data::Dumper; warn Dumper($seen);
377 my $as = ($count > 1 ? "${join}_${count}" : $join);
378 my $rel_info = $self->relationship_info($join);
379 $self->throw_exception("No such relationship ${join}") unless $rel_info;
380 my $type = $rel_info->{attrs}{join_type} || '';
381 return [ { $as => $self->related_source($join)->from,
382 -join_type => $type },
383 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
387 =head2 resolve_condition($cond, $as, $alias|$object)
389 Resolves the passed condition to a concrete query fragment. If given an alias,
390 returns a join condition; if given an object, inverts that object to produce
391 a related conditional from that object.
395 sub resolve_condition {
396 my ($self, $cond, $as, $for) = @_;
398 if (ref $cond eq 'HASH') {
400 while (my ($k, $v) = each %{$cond}) {
401 # XXX should probably check these are valid columns
402 $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
403 $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
404 if (ref $for) { # Object
405 #warn "$self $k $for $v";
406 $ret{$k} = $for->get_column($v);
409 $ret{"${as}.${k}"} = "${for}.${v}";
413 } elsif (ref $cond eq 'ARRAY') {
414 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
416 die("Can't handle this yet :(");
420 =head2 resolve_prefetch (hashref/arrayref/scalar)
422 Accepts one or more relationships for the current source and returns an
423 array of column names for each of those relationships. Column names are
424 prefixed relative to the current source, in accordance with where they appear
425 in the supplied relationships. Examples:
427 my $source = $schema->resultset('Tag')->source;
428 @columns = $source->resolve_prefetch( { cd => 'artist' } );
436 # 'cd.artist.artistid',
440 @columns = $source->resolve_prefetch( qw[/ cd /] );
450 $source = $schema->resultset('CD')->source;
451 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
457 # 'producer.producerid',
463 sub resolve_prefetch {
464 my ($self, $pre, $alias, $seen) = @_;
467 #$alias ||= $self->name;
468 #warn $alias, Dumper $pre;
469 if( ref $pre eq 'ARRAY' ) {
470 return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
472 elsif( ref $pre eq 'HASH' ) {
475 $self->resolve_prefetch($_, $alias, $seen),
476 $self->related_source($_)->resolve_prefetch(
477 $pre->{$_}, "${alias}.$_", $seen)
483 $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
486 my $count = ++$seen->{$pre};
487 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
488 my $rel_info = $self->relationship_info( $pre );
489 $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
490 my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
491 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
492 $self->related_source($pre)->columns;
493 #warn $alias, Dumper (\@ret);
498 =head2 related_source($relname)
500 Returns the result source for the given relationship
505 my ($self, $rel) = @_;
506 if( !$self->has_relationship( $rel ) ) {
507 $self->throw_exception("No such relationship '$rel'");
509 return $self->schema->source($self->relationship_info($rel)->{source});
514 Returns a resultset for the given source created by calling
516 $self->resultset_class->new($self, $self->resultset_attributes)
518 =head2 resultset_class
522 =head2 resultset_attributes
530 return $self->{_resultset} if ref $self->{_resultset} eq $self->resultset_class;
531 return $self->{_resultset} = do {
532 my $rs = $self->resultset_class->new($self, $self->{resultset_attributes});
533 weaken $rs->result_source;
538 =head2 throw_exception
540 See schema's throw_exception
544 sub throw_exception {
546 if (defined $self->schema) {
547 $self->schema->throw_exception(@_);
556 Matt S. Trout <mst@shadowcatsystems.co.uk>
560 You may distribute this code under the same terms as Perl itself.