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