add usage example
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm
CommitLineData
9c992ba1 1package DBIx::Class::ResultSource;
2
3use strict;
4use warnings;
5
6use DBIx::Class::ResultSet;
701da8c4 7use Carp::Clan qw/^DBIx::Class/;
9c992ba1 8
6da5894c 9use Storable;
10
9c992ba1 11use base qw/DBIx::Class/;
12__PACKAGE__->load_components(qw/AccessorGroup/);
13
14__PACKAGE__->mk_group_accessors('simple' =>
5ac6a044 15 qw/_ordered_columns _columns _primaries _unique_constraints name resultset_class resultset_attributes result_class schema from _relationships/);
9c992ba1 16
17=head1 NAME
18
19DBIx::Class::ResultSource - Result source object
20
21=head1 SYNOPSIS
22
23=head1 DESCRIPTION
24
25A ResultSource is a component of a schema from which results can be directly
26retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
27
28=head1 METHODS
29
30=cut
31
32sub new {
33 my ($class, $attrs) = @_;
34 $class = ref $class if ref $class;
35 my $new = bless({ %{$attrs || {}} }, $class);
36 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
5ac6a044 37 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
6da5894c 38 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
39 $new->{_columns} = { %{$new->{_columns}||{}} };
40 $new->{_relationships} = { %{$new->{_relationships}||{}} };
9c992ba1 41 $new->{name} ||= "!!NAME NOT SET!!";
42 return $new;
43}
44
5ac6a044 45=head2 add_columns
46
47 $table->add_columns(qw/col1 col2 col3/);
48
49 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
50
51Adds columns to the result source. If supplied key => hashref pairs uses
52the hashref as the column_info for that column.
53
54=head2 add_column
55
56 $table->add_column('col' => \%info?);
57
58Convenience alias to add_columns
59
60=cut
61
9c992ba1 62sub add_columns {
63 my ($self, @cols) = @_;
571dced3 64 $self->_ordered_columns( \@cols )
65 if !$self->_ordered_columns;
20518cb4 66 my @added;
67 my $columns = $self->_columns;
9c992ba1 68 while (my $col = shift @cols) {
53509665 69
30126ac7 70 my $column_info = ref $cols[0] ? shift(@cols) : {};
53509665 71 # If next entry is { ... } use that for the column info, if not
72 # use an empty hashref
73
20518cb4 74 push(@added, $col) unless exists $columns->{$col};
75
76 $columns->{$col} = $column_info;
9c992ba1 77 }
20518cb4 78 push @{ $self->_ordered_columns }, @added;
30126ac7 79 return $self;
9c992ba1 80}
81
82*add_column = \&add_columns;
83
3842b955 84=head2 has_column
85
9c992ba1 86 if ($obj->has_column($col)) { ... }
87
88Returns 1 if the source has a column of this name, 0 otherwise.
89
90=cut
91
92sub has_column {
93 my ($self, $column) = @_;
94 return exists $self->_columns->{$column};
95}
96
97=head2 column_info
98
99 my $info = $obj->column_info($col);
100
101Returns the column metadata hashref for a column.
102
103=cut
104
105sub column_info {
106 my ($self, $column) = @_;
701da8c4 107 $self->throw_exception("No such column $column")
108 unless exists $self->_columns->{$column};
a953d8d9 109 if ( (! $self->_columns->{$column}->{data_type})
110 && $self->schema && $self->storage() ){
111 my $info;
112############ eval for the case of storage without table
113 eval{
114 $info = $self->storage->columns_info_for ( $self->from() );
115 };
116 if ( ! $@ ){
117 for my $col ( keys %{$self->_columns} ){
118 for my $i ( keys %{$info->{$col}} ){
119 $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
120 }
121 }
122 }
123 }
9c992ba1 124 return $self->_columns->{$column};
125}
126
127=head2 columns
128
20518cb4 129 my @column_names = $obj->columns;
130
131Returns all column names in the order they were declared to add_columns
87f0da6a 132
133=cut
9c992ba1 134
135sub columns {
701da8c4 136 my $self=shift;
137 $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
138 return @{$self->{_ordered_columns}||[]};
571dced3 139}
140
87f0da6a 141=head2 set_primary_key(@cols)
142
9c992ba1 143Defines one or more columns as primary key for this source. Should be
144called after C<add_columns>.
87f0da6a 145
146Additionally, defines a unique constraint named C<primary>.
147
148=cut
9c992ba1 149
150sub set_primary_key {
151 my ($self, @cols) = @_;
152 # check if primary key columns are valid columns
153 for (@cols) {
701da8c4 154 $self->throw_exception("No such column $_ on table ".$self->name)
9c992ba1 155 unless $self->has_column($_);
156 }
157 $self->_primaries(\@cols);
87f0da6a 158
159 $self->add_unique_constraint(primary => \@cols);
9c992ba1 160}
161
87f0da6a 162=head2 primary_columns
163
9c992ba1 164Read-only accessor which returns the list of primary keys.
30126ac7 165
87f0da6a 166=cut
9c992ba1 167
168sub primary_columns {
169 return @{shift->_primaries||[]};
170}
171
87f0da6a 172=head2 add_unique_constraint
173
174Declare a unique constraint on this source. Call once for each unique
175constraint.
176
177 # For e.g. UNIQUE (column1, column2)
178 __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
179
180=cut
181
182sub add_unique_constraint {
183 my ($self, $name, $cols) = @_;
184
185 for (@$cols) {
701da8c4 186 $self->throw_exception("No such column $_ on table ".$self->name)
87f0da6a 187 unless $self->has_column($_);
188 }
189
190 my %unique_constraints = $self->unique_constraints;
191 $unique_constraints{$name} = $cols;
192 $self->_unique_constraints(\%unique_constraints);
193}
194
195=head2 unique_constraints
196
197Read-only accessor which returns the list of unique constraints on this source.
198
199=cut
200
201sub unique_constraints {
202 return %{shift->_unique_constraints||{}};
203}
204
9c992ba1 205=head2 from
206
207Returns an expression of the source to be supplied to storage to specify
208retrieval from this source; in the case of a database the required FROM clause
209contents.
210
211=cut
212
213=head2 storage
214
215Returns the storage handle for the current schema
216
217=cut
218
219sub storage { shift->schema->storage; }
220
8452e496 221=head2 add_relationship
222
223 $source->add_relationship('relname', 'related_source', $cond, $attrs);
224
225The relation name can be arbitrary, but must be unique for each relationship
226attached to this result source. 'related_source' should be the name with
227which the related result source was registered with the current schema
228(for simple schemas this is usally either Some::Namespace::Foo or just Foo)
229
230The condition needs to be an SQL::Abstract-style representation of the join
231between the tables. For example, if you're creating a rel from Foo to Bar,
232
233 { 'foreign.foo_id' => 'self.id' }
234
235will result in the JOIN clause
236
237 foo me JOIN bar bar ON bar.foo_id = me.id
238
239You can specify as many foreign => self mappings as necessary.
240
241Valid attributes are as follows:
242
243=over 4
244
245=item join_type
246
247Explicitly specifies the type of join to use in the relationship. Any SQL
248join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
249command immediately before C<JOIN>.
250
251=item proxy
252
253An arrayref containing a list of accessors in the foreign class to proxy in
254the main class. If, for example, you do the following:
255
fc69fea6 256 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
8452e496 257
258Then, assuming Bar has an accessor named margle, you can do:
259
260 my $obj = Foo->find(1);
261 $obj->margle(10); # set margle; Bar object is created if it doesn't exist
262
263=item accessor
264
265Specifies the type of accessor that should be created for the relationship.
266Valid values are C<single> (for when there is only a single related object),
267C<multi> (when there can be many), and C<filter> (for when there is a single
268related object, but you also want the relationship accessor to double as
269a column accessor). For C<multi> accessors, an add_to_* method is also
270created, which calls C<create_related> for the relationship.
271
272=back
273
274=cut
275
276sub add_relationship {
277 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
701da8c4 278 $self->throw_exception("Can't create relationship without join condition") unless $cond;
8452e496 279 $attrs ||= {};
87772e46 280
8452e496 281 my %rels = %{ $self->_relationships };
282 $rels{$rel} = { class => $f_source_name,
87772e46 283 source => $f_source_name,
8452e496 284 cond => $cond,
285 attrs => $attrs };
286 $self->_relationships(\%rels);
287
30126ac7 288 return $self;
87772e46 289
953a18ef 290 # XXX disabled. doesn't work properly currently. skip in tests.
291
8452e496 292 my $f_source = $self->schema->source($f_source_name);
293 unless ($f_source) {
294 eval "require $f_source_name;";
295 if ($@) {
296 die $@ unless $@ =~ /Can't locate/;
297 }
298 $f_source = $f_source_name->result_source;
87772e46 299 #my $s_class = ref($self->schema);
300 #$f_source_name =~ m/^${s_class}::(.*)$/;
301 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
302 #$f_source = $self->schema->source($f_source_name);
8452e496 303 }
304 return unless $f_source; # Can't test rel without f_source
305
306 eval { $self->resolve_join($rel, 'me') };
307
308 if ($@) { # If the resolve failed, back out and re-throw the error
309 delete $rels{$rel}; #
310 $self->_relationships(\%rels);
701da8c4 311 $self->throw_exception("Error creating relationship $rel: $@");
8452e496 312 }
313 1;
314}
315
316=head2 relationships()
317
318Returns all valid relationship names for this source
319
320=cut
321
322sub relationships {
323 return keys %{shift->_relationships};
324}
325
326=head2 relationship_info($relname)
327
328Returns the relationship information for the specified relationship name
329
330=cut
331
332sub relationship_info {
333 my ($self, $rel) = @_;
334 return $self->_relationships->{$rel};
335}
336
953a18ef 337=head2 has_relationship($rel)
338
339Returns 1 if the source has a relationship of this name, 0 otherwise.
340
341=cut
342
343sub has_relationship {
344 my ($self, $rel) = @_;
345 return exists $self->_relationships->{$rel};
346}
347
8452e496 348=head2 resolve_join($relation)
349
350Returns the join structure required for the related result source
351
352=cut
353
354sub resolve_join {
489709af 355 my ($self, $join, $alias, $seen) = @_;
356 $seen ||= {};
87772e46 357 if (ref $join eq 'ARRAY') {
489709af 358 return map { $self->resolve_join($_, $alias, $seen) } @$join;
87772e46 359 } elsif (ref $join eq 'HASH') {
489709af 360 return
887ce227 361 map {
362 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
363 ($self->resolve_join($_, $alias, $seen),
364 $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
365 } keys %$join;
87772e46 366 } elsif (ref $join) {
701da8c4 367 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
87772e46 368 } else {
489709af 369 my $count = ++$seen->{$join};
370 #use Data::Dumper; warn Dumper($seen);
371 my $as = ($count > 1 ? "${join}_${count}" : $join);
3842b955 372 my $rel_info = $self->relationship_info($join);
701da8c4 373 $self->throw_exception("No such relationship ${join}") unless $rel_info;
3842b955 374 my $type = $rel_info->{attrs}{join_type} || '';
489709af 375 return [ { $as => $self->related_source($join)->from,
953a18ef 376 -join_type => $type },
489709af 377 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
953a18ef 378 }
379}
380
489709af 381=head2 resolve_condition($cond, $as, $alias|$object)
953a18ef 382
3842b955 383Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef 384returns a join condition; if given an object, inverts that object to produce
385a related conditional from that object.
386
387=cut
388
389sub resolve_condition {
489709af 390 my ($self, $cond, $as, $for) = @_;
953a18ef 391 #warn %$cond;
392 if (ref $cond eq 'HASH') {
393 my %ret;
394 while (my ($k, $v) = each %{$cond}) {
395 # XXX should probably check these are valid columns
701da8c4 396 $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
397 $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
953a18ef 398 if (ref $for) { # Object
3842b955 399 #warn "$self $k $for $v";
400 $ret{$k} = $for->get_column($v);
401 #warn %ret;
953a18ef 402 } else {
489709af 403 $ret{"${as}.${k}"} = "${for}.${v}";
953a18ef 404 }
953a18ef 405 }
406 return \%ret;
5efe4c79 407 } elsif (ref $cond eq 'ARRAY') {
489709af 408 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
953a18ef 409 } else {
410 die("Can't handle this yet :(");
87772e46 411 }
412}
413
b3e8ac9b 414=head2 resolve_prefetch (hashref/arrayref/scalar)
415
416Accepts one or more relationships for the current source and returns an
417array of column names for each of those relationships. Column names are
418prefixed relative to the current source, in accordance with where they appear
419in the supplied relationships. Examples:
420
5ac6a044 421 my $source = $schema->resultset('Tag')->source;
b3e8ac9b 422 @columns = $source->resolve_prefetch( { cd => 'artist' } );
423
424 # @columns =
425 #(
426 # 'cd.cdid',
427 # 'cd.artist',
428 # 'cd.title',
429 # 'cd.year',
430 # 'cd.artist.artistid',
431 # 'cd.artist.name'
432 #)
433
434 @columns = $source->resolve_prefetch( qw[/ cd /] );
435
436 # @columns =
437 #(
438 # 'cd.cdid',
439 # 'cd.artist',
440 # 'cd.title',
441 # 'cd.year'
442 #)
443
444 $source = $schema->resultset('CD')->source;
445 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
446
447 # @columns =
448 #(
449 # 'artist.artistid',
450 # 'artist.name',
451 # 'producer.producerid',
452 # 'producer.name'
453 #)
454
455=cut
456
457sub resolve_prefetch {
489709af 458 my ($self, $pre, $alias, $seen) = @_;
459 $seen ||= {};
b3e8ac9b 460 use Data::Dumper;
461 #$alias ||= $self->name;
462 #warn $alias, Dumper $pre;
463 if( ref $pre eq 'ARRAY' ) {
489709af 464 return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
b3e8ac9b 465 }
466 elsif( ref $pre eq 'HASH' ) {
467 my @ret =
468 map {
489709af 469 $self->resolve_prefetch($_, $alias, $seen),
470 $self->related_source($_)->resolve_prefetch(
471 $pre->{$_}, "${alias}.$_", $seen)
472 } keys %$pre;
b3e8ac9b 473 #die Dumper \@ret;
474 return @ret;
475 }
476 elsif( ref $pre ) {
701da8c4 477 $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
b3e8ac9b 478 }
479 else {
489709af 480 my $count = ++$seen->{$pre};
481 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
b3e8ac9b 482 my $rel_info = $self->relationship_info( $pre );
701da8c4 483 $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
489709af 484 my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
485 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
486 $self->related_source($pre)->columns;
b3e8ac9b 487 #warn $alias, Dumper (\@ret);
489709af 488 #return @ret;
b3e8ac9b 489 }
490}
953a18ef 491
87772e46 492=head2 related_source($relname)
493
494Returns the result source for the given relationship
495
496=cut
497
498sub related_source {
499 my ($self, $rel) = @_;
aea52c85 500 if( !$self->has_relationship( $rel ) ) {
701da8c4 501 $self->throw_exception("No such relationship '$rel'");
aea52c85 502 }
87772e46 503 return $self->schema->source($self->relationship_info($rel)->{source});
8452e496 504}
505
5ac6a044 506=head2 resultset
507
508Returns a resultset for the given source created by calling
509
510$self->resultset_class->new($self, $self->resultset_attributes)
511
512=head2 resultset_class
513
514Simple accessor.
515
516=head2 resultset_attributes
517
518Simple accessor.
519
520=cut
521
522sub resultset {
523 my $self = shift;
524 return $self->resultset_class->new($self, $self->{resultset_attributes});
525}
526
701da8c4 527=head2 throw_exception
528
529See schema's throw_exception
530
531=cut
532
533sub throw_exception {
534 my $self = shift;
535 if (defined $self->schema) {
536 $self->schema->throw_exception(@_);
537 } else {
538 croak(@_);
539 }
540}
541
542
9c992ba1 543=head1 AUTHORS
544
545Matt S. Trout <mst@shadowcatsystems.co.uk>
546
547=head1 LICENSE
548
549You may distribute this code under the same terms as Perl itself.
550
551=cut
552