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