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!!";
43 $new->{_columns_info_loaded} ||= 0;
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 #warn $self->{_columns_info_loaded}, "\n";
112 if ( ! $self->_columns->{$column}->{data_type}
113 && ! $self->{_columns_info_loaded}
114 && $self->schema && $self->storage() ){
115 $self->{_columns_info_loaded}++;
117 ############ eval for the case of storage without table
119 $info = $self->storage->columns_info_for ( $self->from() );
122 for my $col ( keys %{$self->_columns} ){
123 for my $i ( keys %{$info->{$col}} ){
124 $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
129 return $self->_columns->{$column};
134 my @column_names = $obj->columns;
136 Returns all column names in the order they were declared to add_columns
142 $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
143 return @{$self->{_ordered_columns}||[]};
146 =head2 set_primary_key(@cols)
148 Defines one or more columns as primary key for this source. Should be
149 called after C<add_columns>.
151 Additionally, defines a unique constraint named C<primary>.
155 sub set_primary_key {
156 my ($self, @cols) = @_;
157 # check if primary key columns are valid columns
159 $self->throw_exception("No such column $_ on table ".$self->name)
160 unless $self->has_column($_);
162 $self->_primaries(\@cols);
164 $self->add_unique_constraint(primary => \@cols);
167 =head2 primary_columns
169 Read-only accessor which returns the list of primary keys.
173 sub primary_columns {
174 return @{shift->_primaries||[]};
177 =head2 add_unique_constraint
179 Declare a unique constraint on this source. Call once for each unique
182 # For e.g. UNIQUE (column1, column2)
183 __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
187 sub add_unique_constraint {
188 my ($self, $name, $cols) = @_;
191 $self->throw_exception("No such column $_ on table ".$self->name)
192 unless $self->has_column($_);
195 my %unique_constraints = $self->unique_constraints;
196 $unique_constraints{$name} = $cols;
197 $self->_unique_constraints(\%unique_constraints);
200 =head2 unique_constraints
202 Read-only accessor which returns the list of unique constraints on this source.
206 sub unique_constraints {
207 return %{shift->_unique_constraints||{}};
212 Returns an expression of the source to be supplied to storage to specify
213 retrieval from this source; in the case of a database the required FROM clause
220 Returns the storage handle for the current schema
224 sub storage { shift->schema->storage; }
226 =head2 add_relationship
228 $source->add_relationship('relname', 'related_source', $cond, $attrs);
230 The relation name can be arbitrary, but must be unique for each relationship
231 attached to this result source. 'related_source' should be the name with
232 which the related result source was registered with the current schema
233 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
235 The condition needs to be an SQL::Abstract-style representation of the join
236 between the tables. For example, if you're creating a rel from Foo to Bar,
238 { 'foreign.foo_id' => 'self.id' }
240 will result in the JOIN clause
242 foo me JOIN bar bar ON bar.foo_id = me.id
244 You can specify as many foreign => self mappings as necessary.
246 Valid attributes are as follows:
252 Explicitly specifies the type of join to use in the relationship. Any SQL
253 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
254 command immediately before C<JOIN>.
258 An arrayref containing a list of accessors in the foreign class to proxy in
259 the main class. If, for example, you do the following:
261 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
263 Then, assuming Bar has an accessor named margle, you can do:
265 my $obj = Foo->find(1);
266 $obj->margle(10); # set margle; Bar object is created if it doesn't exist
270 Specifies the type of accessor that should be created for the relationship.
271 Valid values are C<single> (for when there is only a single related object),
272 C<multi> (when there can be many), and C<filter> (for when there is a single
273 related object, but you also want the relationship accessor to double as
274 a column accessor). For C<multi> accessors, an add_to_* method is also
275 created, which calls C<create_related> for the relationship.
281 sub add_relationship {
282 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
283 $self->throw_exception("Can't create relationship without join condition") unless $cond;
286 my %rels = %{ $self->_relationships };
287 $rels{$rel} = { class => $f_source_name,
288 source => $f_source_name,
291 $self->_relationships(\%rels);
295 # XXX disabled. doesn't work properly currently. skip in tests.
297 my $f_source = $self->schema->source($f_source_name);
299 eval "require $f_source_name;";
301 die $@ unless $@ =~ /Can't locate/;
303 $f_source = $f_source_name->result_source;
304 #my $s_class = ref($self->schema);
305 #$f_source_name =~ m/^${s_class}::(.*)$/;
306 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
307 #$f_source = $self->schema->source($f_source_name);
309 return unless $f_source; # Can't test rel without f_source
311 eval { $self->resolve_join($rel, 'me') };
313 if ($@) { # If the resolve failed, back out and re-throw the error
314 delete $rels{$rel}; #
315 $self->_relationships(\%rels);
316 $self->throw_exception("Error creating relationship $rel: $@");
321 =head2 relationships()
323 Returns all valid relationship names for this source
328 return keys %{shift->_relationships};
331 =head2 relationship_info($relname)
333 Returns the relationship information for the specified relationship name
337 sub relationship_info {
338 my ($self, $rel) = @_;
339 return $self->_relationships->{$rel};
342 =head2 has_relationship($rel)
344 Returns 1 if the source has a relationship of this name, 0 otherwise.
348 sub has_relationship {
349 my ($self, $rel) = @_;
350 return exists $self->_relationships->{$rel};
353 =head2 resolve_join($relation)
355 Returns the join structure required for the related result source
360 my ($self, $join, $alias, $seen) = @_;
362 if (ref $join eq 'ARRAY') {
363 return map { $self->resolve_join($_, $alias, $seen) } @$join;
364 } elsif (ref $join eq 'HASH') {
367 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
368 ($self->resolve_join($_, $alias, $seen),
369 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
371 } elsif (ref $join) {
372 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
374 my $count = ++$seen->{$join};
375 #use Data::Dumper; warn Dumper($seen);
376 my $as = ($count > 1 ? "${join}_${count}" : $join);
377 my $rel_info = $self->relationship_info($join);
378 $self->throw_exception("No such relationship ${join}") unless $rel_info;
379 my $type = $rel_info->{attrs}{join_type} || '';
380 return [ { $as => $self->related_source($join)->from,
381 -join_type => $type },
382 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
386 =head2 resolve_condition($cond, $as, $alias|$object)
388 Resolves the passed condition to a concrete query fragment. If given an alias,
389 returns a join condition; if given an object, inverts that object to produce
390 a related conditional from that object.
394 sub resolve_condition {
395 my ($self, $cond, $as, $for) = @_;
397 if (ref $cond eq 'HASH') {
399 while (my ($k, $v) = each %{$cond}) {
400 # XXX should probably check these are valid columns
401 $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
402 $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
403 if (ref $for) { # Object
404 #warn "$self $k $for $v";
405 $ret{$k} = $for->get_column($v);
408 $ret{"${as}.${k}"} = "${for}.${v}";
412 } elsif (ref $cond eq 'ARRAY') {
413 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
415 die("Can't handle this yet :(");
419 =head2 resolve_prefetch (hashref/arrayref/scalar)
421 Accepts one or more relationships for the current source and returns an
422 array of column names for each of those relationships. Column names are
423 prefixed relative to the current source, in accordance with where they appear
424 in the supplied relationships. Examples:
426 my $source = $schema->resultset('Tag')->source;
427 @columns = $source->resolve_prefetch( { cd => 'artist' } );
435 # 'cd.artist.artistid',
439 @columns = $source->resolve_prefetch( qw[/ cd /] );
449 $source = $schema->resultset('CD')->source;
450 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
456 # 'producer.producerid',
462 sub resolve_prefetch {
463 my ($self, $pre, $alias, $seen) = @_;
466 #$alias ||= $self->name;
467 #warn $alias, Dumper $pre;
468 if( ref $pre eq 'ARRAY' ) {
469 return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
471 elsif( ref $pre eq 'HASH' ) {
474 $self->resolve_prefetch($_, $alias, $seen),
475 $self->related_source($_)->resolve_prefetch(
476 $pre->{$_}, "${alias}.$_", $seen)
482 $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
485 my $count = ++$seen->{$pre};
486 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
487 my $rel_info = $self->relationship_info( $pre );
488 $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
489 my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
490 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
491 $self->related_source($pre)->columns;
492 #warn $alias, Dumper (\@ret);
497 =head2 related_source($relname)
499 Returns the result source for the given relationship
504 my ($self, $rel) = @_;
505 if( !$self->has_relationship( $rel ) ) {
506 $self->throw_exception("No such relationship '$rel'");
508 return $self->schema->source($self->relationship_info($rel)->{source});
513 Returns a resultset for the given source created by calling
515 $self->resultset_class->new($self, $self->resultset_attributes)
517 =head2 resultset_class
521 =head2 resultset_attributes
529 return $self->resultset_class->new($self, $self->{resultset_attributes});
532 =head2 throw_exception
534 See schema's throw_exception
538 sub throw_exception {
540 if (defined $self->schema) {
541 $self->schema->throw_exception(@_);
550 Matt S. Trout <mst@shadowcatsystems.co.uk>
554 You may distribute this code under the same terms as Perl itself.