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!!";
49 $table->add_columns(qw/col1 col2 col3/);
51 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
53 Adds columns to the result source. If supplied key => hashref pairs uses
54 the hashref as the column_info for that column.
58 $table->add_column('col' => \%info?);
60 Convenience alias to add_columns
65 my ($self, @cols) = @_;
66 $self->_ordered_columns( \@cols )
67 if !$self->_ordered_columns;
69 my $columns = $self->_columns;
70 while (my $col = shift @cols) {
72 my $column_info = ref $cols[0] ? shift(@cols) : {};
73 # If next entry is { ... } use that for the column info, if not
74 # use an empty hashref
76 push(@added, $col) unless exists $columns->{$col};
78 $columns->{$col} = $column_info;
80 push @{ $self->_ordered_columns }, @added;
84 *add_column = \&add_columns;
88 if ($obj->has_column($col)) { ... }
90 Returns 1 if the source has a column of this name, 0 otherwise.
95 my ($self, $column) = @_;
96 return exists $self->_columns->{$column};
101 my $info = $obj->column_info($col);
103 Returns the column metadata hashref for a column.
108 my ($self, $column) = @_;
109 $self->throw_exception("No such column $column")
110 unless exists $self->_columns->{$column};
111 if ( (! $self->_columns->{$column}->{data_type})
112 && $self->schema && $self->storage() ){
114 ############ eval for the case of storage without table
116 $info = $self->storage->columns_info_for ( $self->from() );
119 for my $col ( keys %{$self->_columns} ){
120 for my $i ( keys %{$info->{$col}} ){
121 $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
126 return $self->_columns->{$column};
131 my @column_names = $obj->columns;
133 Returns all column names in the order they were declared to add_columns
139 $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
140 return @{$self->{_ordered_columns}||[]};
143 =head2 set_primary_key(@cols)
145 Defines one or more columns as primary key for this source. Should be
146 called after C<add_columns>.
148 Additionally, defines a unique constraint named C<primary>.
152 sub set_primary_key {
153 my ($self, @cols) = @_;
154 # check if primary key columns are valid columns
156 $self->throw_exception("No such column $_ on table ".$self->name)
157 unless $self->has_column($_);
159 $self->_primaries(\@cols);
161 $self->add_unique_constraint(primary => \@cols);
164 =head2 primary_columns
166 Read-only accessor which returns the list of primary keys.
170 sub primary_columns {
171 return @{shift->_primaries||[]};
174 =head2 add_unique_constraint
176 Declare a unique constraint on this source. Call once for each unique
179 # For e.g. UNIQUE (column1, column2)
180 __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
184 sub add_unique_constraint {
185 my ($self, $name, $cols) = @_;
188 $self->throw_exception("No such column $_ on table ".$self->name)
189 unless $self->has_column($_);
192 my %unique_constraints = $self->unique_constraints;
193 $unique_constraints{$name} = $cols;
194 $self->_unique_constraints(\%unique_constraints);
197 =head2 unique_constraints
199 Read-only accessor which returns the list of unique constraints on this source.
203 sub unique_constraints {
204 return %{shift->_unique_constraints||{}};
209 Returns an expression of the source to be supplied to storage to specify
210 retrieval from this source; in the case of a database the required FROM clause
217 Returns the storage handle for the current schema
221 sub storage { shift->schema->storage; }
223 =head2 add_relationship
225 $source->add_relationship('relname', 'related_source', $cond, $attrs);
227 The relation name can be arbitrary, but must be unique for each relationship
228 attached to this result source. 'related_source' should be the name with
229 which the related result source was registered with the current schema
230 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
232 The condition needs to be an SQL::Abstract-style representation of the join
233 between the tables. For example, if you're creating a rel from Foo to Bar,
235 { 'foreign.foo_id' => 'self.id' }
237 will result in the JOIN clause
239 foo me JOIN bar bar ON bar.foo_id = me.id
241 You can specify as many foreign => self mappings as necessary.
243 Valid attributes are as follows:
249 Explicitly specifies the type of join to use in the relationship. Any SQL
250 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
251 command immediately before C<JOIN>.
255 An arrayref containing a list of accessors in the foreign class to proxy in
256 the main class. If, for example, you do the following:
258 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
260 Then, assuming Bar has an accessor named margle, you can do:
262 my $obj = Foo->find(1);
263 $obj->margle(10); # set margle; Bar object is created if it doesn't exist
267 Specifies the type of accessor that should be created for the relationship.
268 Valid values are C<single> (for when there is only a single related object),
269 C<multi> (when there can be many), and C<filter> (for when there is a single
270 related object, but you also want the relationship accessor to double as
271 a column accessor). For C<multi> accessors, an add_to_* method is also
272 created, which calls C<create_related> for the relationship.
278 sub add_relationship {
279 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
280 $self->throw_exception("Can't create relationship without join condition") unless $cond;
283 my %rels = %{ $self->_relationships };
284 $rels{$rel} = { class => $f_source_name,
285 source => $f_source_name,
288 $self->_relationships(\%rels);
292 # XXX disabled. doesn't work properly currently. skip in tests.
294 my $f_source = $self->schema->source($f_source_name);
296 eval "require $f_source_name;";
298 die $@ unless $@ =~ /Can't locate/;
300 $f_source = $f_source_name->result_source;
301 #my $s_class = ref($self->schema);
302 #$f_source_name =~ m/^${s_class}::(.*)$/;
303 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
304 #$f_source = $self->schema->source($f_source_name);
306 return unless $f_source; # Can't test rel without f_source
308 eval { $self->resolve_join($rel, 'me') };
310 if ($@) { # If the resolve failed, back out and re-throw the error
311 delete $rels{$rel}; #
312 $self->_relationships(\%rels);
313 $self->throw_exception("Error creating relationship $rel: $@");
318 =head2 relationships()
320 Returns all valid relationship names for this source
325 return keys %{shift->_relationships};
328 =head2 relationship_info($relname)
330 Returns the relationship information for the specified relationship name
334 sub relationship_info {
335 my ($self, $rel) = @_;
336 return $self->_relationships->{$rel};
339 =head2 has_relationship($rel)
341 Returns 1 if the source has a relationship of this name, 0 otherwise.
345 sub has_relationship {
346 my ($self, $rel) = @_;
347 return exists $self->_relationships->{$rel};
350 =head2 resolve_join($relation)
352 Returns the join structure required for the related result source
357 my ($self, $join, $alias, $seen) = @_;
359 if (ref $join eq 'ARRAY') {
360 return map { $self->resolve_join($_, $alias, $seen) } @$join;
361 } elsif (ref $join eq 'HASH') {
364 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
365 ($self->resolve_join($_, $alias, $seen),
366 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
368 } elsif (ref $join) {
369 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
371 my $count = ++$seen->{$join};
372 #use Data::Dumper; warn Dumper($seen);
373 my $as = ($count > 1 ? "${join}_${count}" : $join);
374 my $rel_info = $self->relationship_info($join);
375 $self->throw_exception("No such relationship ${join}") unless $rel_info;
376 my $type = $rel_info->{attrs}{join_type} || '';
377 return [ { $as => $self->related_source($join)->from,
378 -join_type => $type },
379 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
383 =head2 resolve_condition($cond, $as, $alias|$object)
385 Resolves the passed condition to a concrete query fragment. If given an alias,
386 returns a join condition; if given an object, inverts that object to produce
387 a related conditional from that object.
391 sub resolve_condition {
392 my ($self, $cond, $as, $for) = @_;
394 if (ref $cond eq 'HASH') {
396 while (my ($k, $v) = each %{$cond}) {
397 # XXX should probably check these are valid columns
398 $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
399 $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
400 if (ref $for) { # Object
401 #warn "$self $k $for $v";
402 $ret{$k} = $for->get_column($v);
405 $ret{"${as}.${k}"} = "${for}.${v}";
409 } elsif (ref $cond eq 'ARRAY') {
410 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
412 die("Can't handle this yet :(");
416 =head2 resolve_prefetch (hashref/arrayref/scalar)
418 Accepts one or more relationships for the current source and returns an
419 array of column names for each of those relationships. Column names are
420 prefixed relative to the current source, in accordance with where they appear
421 in the supplied relationships. Examples:
423 my $source = $schema->resultset('Tag')->source;
424 @columns = $source->resolve_prefetch( { cd => 'artist' } );
432 # 'cd.artist.artistid',
436 @columns = $source->resolve_prefetch( qw[/ cd /] );
446 $source = $schema->resultset('CD')->source;
447 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
453 # 'producer.producerid',
459 sub resolve_prefetch {
460 my ($self, $pre, $alias, $seen) = @_;
463 #$alias ||= $self->name;
464 #warn $alias, Dumper $pre;
465 if( ref $pre eq 'ARRAY' ) {
466 return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
468 elsif( ref $pre eq 'HASH' ) {
471 $self->resolve_prefetch($_, $alias, $seen),
472 $self->related_source($_)->resolve_prefetch(
473 $pre->{$_}, "${alias}.$_", $seen)
479 $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
482 my $count = ++$seen->{$pre};
483 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
484 my $rel_info = $self->relationship_info( $pre );
485 $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
486 my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
487 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
488 $self->related_source($pre)->columns;
489 #warn $alias, Dumper (\@ret);
494 =head2 related_source($relname)
496 Returns the result source for the given relationship
501 my ($self, $rel) = @_;
502 if( !$self->has_relationship( $rel ) ) {
503 $self->throw_exception("No such relationship '$rel'");
505 return $self->schema->source($self->relationship_info($rel)->{source});
510 Returns a resultset for the given source created by calling
512 $self->resultset_class->new($self, $self->resultset_attributes)
514 =head2 resultset_class
518 =head2 resultset_attributes
526 return $self->{_resultset} if ref $self->{_resultset} eq $self->resultset_class;
527 return $self->{_resultset} = do {
528 my $rs = $self->resultset_class->new($self, $self->{resultset_attributes});
529 weaken $rs->result_source;
534 =head2 throw_exception
536 See schema's throw_exception
540 sub throw_exception {
542 if (defined $self->schema) {
543 $self->schema->throw_exception(@_);
552 Matt S. Trout <mst@shadowcatsystems.co.uk>
556 You may distribute this code under the same terms as Perl itself.