1 package DBIx::Class::ResultSource;
6 use DBIx::Class::ResultSet;
7 use Carp::Clan qw/^DBIx::Class/;
11 use base qw/DBIx::Class/;
12 __PACKAGE__->load_components(qw/AccessorGroup/);
14 __PACKAGE__->mk_group_accessors('simple' =>
15 qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes schema from _relationships/);
16 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/);
20 DBIx::Class::ResultSource - Result source object
26 A ResultSource is a component of a schema from which results can be directly
27 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
34 my ($class, $attrs) = @_;
35 $class = ref $class if ref $class;
36 my $new = bless({ %{$attrs || {}} }, $class);
37 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
38 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
39 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
40 $new->{_columns} = { %{$new->{_columns}||{}} };
41 $new->{_relationships} = { %{$new->{_relationships}||{}} };
42 $new->{name} ||= "!!NAME NOT SET!!";
48 $table->add_columns(qw/col1 col2 col3/);
50 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
52 Adds columns to the result source. If supplied key => hashref pairs uses
53 the hashref as the column_info for that column.
57 $table->add_column('col' => \%info?);
59 Convenience alias to add_columns
64 my ($self, @cols) = @_;
65 $self->_ordered_columns( \@cols )
66 if !$self->_ordered_columns;
68 my $columns = $self->_columns;
69 while (my $col = shift @cols) {
71 my $column_info = ref $cols[0] ? shift(@cols) : {};
72 # If next entry is { ... } use that for the column info, if not
73 # use an empty hashref
75 push(@added, $col) unless exists $columns->{$col};
77 $columns->{$col} = $column_info;
79 push @{ $self->_ordered_columns }, @added;
83 *add_column = \&add_columns;
87 if ($obj->has_column($col)) { ... }
89 Returns 1 if the source has a column of this name, 0 otherwise.
94 my ($self, $column) = @_;
95 return exists $self->_columns->{$column};
100 my $info = $obj->column_info($col);
102 Returns the column metadata hashref for a column.
107 my ($self, $column) = @_;
108 $self->throw_exception("No such column $column")
109 unless exists $self->_columns->{$column};
110 if ( (! $self->_columns->{$column}->{data_type})
111 && $self->schema && $self->storage() ){
113 ############ eval for the case of storage without table
115 $info = $self->storage->columns_info_for ( $self->from() );
118 for my $col ( keys %{$self->_columns} ){
119 for my $i ( keys %{$info->{$col}} ){
120 $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
125 return $self->_columns->{$column};
130 my @column_names = $obj->columns;
132 Returns all column names in the order they were declared to add_columns
138 $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
139 return @{$self->{_ordered_columns}||[]};
142 =head2 set_primary_key(@cols)
144 Defines one or more columns as primary key for this source. Should be
145 called after C<add_columns>.
147 Additionally, defines a unique constraint named C<primary>.
151 sub set_primary_key {
152 my ($self, @cols) = @_;
153 # check if primary key columns are valid columns
155 $self->throw_exception("No such column $_ on table ".$self->name)
156 unless $self->has_column($_);
158 $self->_primaries(\@cols);
160 $self->add_unique_constraint(primary => \@cols);
163 =head2 primary_columns
165 Read-only accessor which returns the list of primary keys.
169 sub primary_columns {
170 return @{shift->_primaries||[]};
173 =head2 add_unique_constraint
175 Declare a unique constraint on this source. Call once for each unique
178 # For e.g. UNIQUE (column1, column2)
179 __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
183 sub add_unique_constraint {
184 my ($self, $name, $cols) = @_;
187 $self->throw_exception("No such column $_ on table ".$self->name)
188 unless $self->has_column($_);
191 my %unique_constraints = $self->unique_constraints;
192 $unique_constraints{$name} = $cols;
193 $self->_unique_constraints(\%unique_constraints);
196 =head2 unique_constraints
198 Read-only accessor which returns the list of unique constraints on this source.
202 sub unique_constraints {
203 return %{shift->_unique_constraints||{}};
208 Returns an expression of the source to be supplied to storage to specify
209 retrieval from this source; in the case of a database the required FROM clause
216 Returns the storage handle for the current schema
220 sub storage { shift->schema->storage; }
222 =head2 add_relationship
224 $source->add_relationship('relname', 'related_source', $cond, $attrs);
226 The relation name can be arbitrary, but must be unique for each relationship
227 attached to this result source. 'related_source' should be the name with
228 which the related result source was registered with the current schema
229 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
231 The condition needs to be an SQL::Abstract-style representation of the join
232 between the tables. For example, if you're creating a rel from Foo to Bar,
234 { 'foreign.foo_id' => 'self.id' }
236 will result in the JOIN clause
238 foo me JOIN bar bar ON bar.foo_id = me.id
240 You can specify as many foreign => self mappings as necessary.
242 Valid attributes are as follows:
248 Explicitly specifies the type of join to use in the relationship. Any SQL
249 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
250 command immediately before C<JOIN>.
254 An arrayref containing a list of accessors in the foreign class to proxy in
255 the main class. If, for example, you do the following:
257 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
259 Then, assuming Bar has an accessor named margle, you can do:
261 my $obj = Foo->find(1);
262 $obj->margle(10); # set margle; Bar object is created if it doesn't exist
266 Specifies the type of accessor that should be created for the relationship.
267 Valid values are C<single> (for when there is only a single related object),
268 C<multi> (when there can be many), and C<filter> (for when there is a single
269 related object, but you also want the relationship accessor to double as
270 a column accessor). For C<multi> accessors, an add_to_* method is also
271 created, which calls C<create_related> for the relationship.
277 sub add_relationship {
278 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
279 $self->throw_exception("Can't create relationship without join condition") unless $cond;
282 my %rels = %{ $self->_relationships };
283 $rels{$rel} = { class => $f_source_name,
284 source => $f_source_name,
287 $self->_relationships(\%rels);
291 # XXX disabled. doesn't work properly currently. skip in tests.
293 my $f_source = $self->schema->source($f_source_name);
295 eval "require $f_source_name;";
297 die $@ unless $@ =~ /Can't locate/;
299 $f_source = $f_source_name->result_source;
300 #my $s_class = ref($self->schema);
301 #$f_source_name =~ m/^${s_class}::(.*)$/;
302 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
303 #$f_source = $self->schema->source($f_source_name);
305 return unless $f_source; # Can't test rel without f_source
307 eval { $self->resolve_join($rel, 'me') };
309 if ($@) { # If the resolve failed, back out and re-throw the error
310 delete $rels{$rel}; #
311 $self->_relationships(\%rels);
312 $self->throw_exception("Error creating relationship $rel: $@");
317 =head2 relationships()
319 Returns all valid relationship names for this source
324 return keys %{shift->_relationships};
327 =head2 relationship_info($relname)
329 Returns the relationship information for the specified relationship name
333 sub relationship_info {
334 my ($self, $rel) = @_;
335 return $self->_relationships->{$rel};
338 =head2 has_relationship($rel)
340 Returns 1 if the source has a relationship of this name, 0 otherwise.
344 sub has_relationship {
345 my ($self, $rel) = @_;
346 return exists $self->_relationships->{$rel};
349 =head2 resolve_join($relation)
351 Returns the join structure required for the related result source
356 my ($self, $join, $alias, $seen) = @_;
358 if (ref $join eq 'ARRAY') {
359 return map { $self->resolve_join($_, $alias, $seen) } @$join;
360 } elsif (ref $join eq 'HASH') {
363 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
364 ($self->resolve_join($_, $alias, $seen),
365 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
367 } elsif (ref $join) {
368 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
370 my $count = ++$seen->{$join};
371 #use Data::Dumper; warn Dumper($seen);
372 my $as = ($count > 1 ? "${join}_${count}" : $join);
373 my $rel_info = $self->relationship_info($join);
374 $self->throw_exception("No such relationship ${join}") unless $rel_info;
375 my $type = $rel_info->{attrs}{join_type} || '';
376 return [ { $as => $self->related_source($join)->from,
377 -join_type => $type },
378 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
382 =head2 resolve_condition($cond, $as, $alias|$object)
384 Resolves the passed condition to a concrete query fragment. If given an alias,
385 returns a join condition; if given an object, inverts that object to produce
386 a related conditional from that object.
390 sub resolve_condition {
391 my ($self, $cond, $as, $for) = @_;
393 if (ref $cond eq 'HASH') {
395 while (my ($k, $v) = each %{$cond}) {
396 # XXX should probably check these are valid columns
397 $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
398 $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
399 if (ref $for) { # Object
400 #warn "$self $k $for $v";
401 $ret{$k} = $for->get_column($v);
404 $ret{"${as}.${k}"} = "${for}.${v}";
408 } elsif (ref $cond eq 'ARRAY') {
409 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
411 die("Can't handle this yet :(");
415 =head2 resolve_prefetch (hashref/arrayref/scalar)
417 Accepts one or more relationships for the current source and returns an
418 array of column names for each of those relationships. Column names are
419 prefixed relative to the current source, in accordance with where they appear
420 in the supplied relationships. Examples:
422 my $source = $schema->resultset('Tag')->source;
423 @columns = $source->resolve_prefetch( { cd => 'artist' } );
431 # 'cd.artist.artistid',
435 @columns = $source->resolve_prefetch( qw[/ cd /] );
445 $source = $schema->resultset('CD')->source;
446 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
452 # 'producer.producerid',
458 sub resolve_prefetch {
459 my ($self, $pre, $alias, $seen) = @_;
462 #$alias ||= $self->name;
463 #warn $alias, Dumper $pre;
464 if( ref $pre eq 'ARRAY' ) {
465 return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
467 elsif( ref $pre eq 'HASH' ) {
470 $self->resolve_prefetch($_, $alias, $seen),
471 $self->related_source($_)->resolve_prefetch(
472 $pre->{$_}, "${alias}.$_", $seen)
478 $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
481 my $count = ++$seen->{$pre};
482 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
483 my $rel_info = $self->relationship_info( $pre );
484 $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
485 my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
486 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
487 $self->related_source($pre)->columns;
488 #warn $alias, Dumper (\@ret);
493 =head2 related_source($relname)
495 Returns the result source for the given relationship
500 my ($self, $rel) = @_;
501 if( !$self->has_relationship( $rel ) ) {
502 $self->throw_exception("No such relationship '$rel'");
504 return $self->schema->source($self->relationship_info($rel)->{source});
509 Returns a resultset for the given source created by calling
511 $self->resultset_class->new($self, $self->resultset_attributes)
513 =head2 resultset_class
517 =head2 resultset_attributes
525 return $self->resultset_class->new($self, $self->{resultset_attributes});
528 =head2 throw_exception
530 See schema's throw_exception
534 sub throw_exception {
536 if (defined $self->schema) {
537 $self->schema->throw_exception(@_);
546 Matt S. Trout <mst@shadowcatsystems.co.uk>
550 You may distribute this code under the same terms as Perl itself.