8b27139730723337ee9fb240044a102a9edbbe0b
[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 use Storable;
9
10 use base qw/DBIx::Class/;
11 __PACKAGE__->load_components(qw/AccessorGroup/);
12
13 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
14   _columns _primaries _unique_constraints name resultset_attributes
15   schema from _relationships/);
16
17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
18   result_class/);
19
20 =head1 NAME
21
22 DBIx::Class::ResultSource - Result source object
23
24 =head1 SYNOPSIS
25
26 =head1 DESCRIPTION
27
28 A ResultSource is a component of a schema from which results can be directly
29 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
30
31 =head1 METHODS
32
33 =cut
34
35 sub new {
36   my ($class, $attrs) = @_;
37   $class = ref $class if ref $class;
38   my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
39   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
40   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
41   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
42   $new->{_columns} = { %{$new->{_columns}||{}} };
43   $new->{_relationships} = { %{$new->{_relationships}||{}} };
44   $new->{name} ||= "!!NAME NOT SET!!";
45   $new->{_columns_info_loaded} ||= 0;
46   return $new;
47 }
48
49 =pod
50
51 =head2 add_columns
52
53   $table->add_columns(qw/col1 col2 col3/);
54
55   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
56
57 Adds columns to the result source. If supplied key => hashref pairs uses
58 the hashref as the column_info for that column.
59
60 Repeated calls of this method will add more columns, not replace them.
61
62 The contents of the column_info are not set in stone, the following
63 keys are currently recognised/used by DBIx::Class. 
64
65 =over 4
66
67 =item accessor
68
69 Use this to set the name of the accessor for this column. If unset,
70 the name of the column will be used.
71
72 =item data_type
73
74 This contains the column type, it is automatically filled by the
75 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
76 L<DBIx::Class::Schema::Loader> module. If you do not enter the
77 data_type, DBIx::Class will attempt to retrieve it from the
78 database for you, using L<DBI>s column_info method. The values of this
79 key are typically upper-cased.
80
81 Currently there is no standard set of values for the data_type, use
82 whatever your database(s) support.
83
84 =item size
85
86 The length of your column, if it is a column type that can have a size
87 restriction. This is currently not used by DBIx::Class.
88
89 =item is_nullable
90
91 If the column is allowed to contain NULL values, set a true value
92 (typically 1), here. This is currently not used by DBIx::Class.
93
94 =item is_auto_increment
95
96 Set this to a true value if this is a column that is somehow
97 automatically filled. This is used to determine which columns to empty
98 when cloning objects using C<copy>.
99
100 =item is_foreign_key
101
102 Set this to a true value if this column represents a key from a
103 foreign table. This is currently not used by DBIx::Class.
104
105 =item default_value
106
107 Set this to the default value which will be inserted into this column
108 by the database. Can contain either values or functions. This is
109 currently not used by DBIx::Class.
110
111 =item sequence
112
113 Sets the name of the sequence to use to generate values.  If not 
114 specified, L<DBIx::Class::PK::Auto> will attempt to retrieve the 
115 name of the sequence from the database automatically.
116
117 =back
118
119 =head2 add_column
120
121   $table->add_column('col' => \%info?);
122
123 Convenience alias to add_columns
124
125 =cut
126
127 sub add_columns {
128   my ($self, @cols) = @_;
129   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
130   
131   my @added;
132   my $columns = $self->_columns;
133   while (my $col = shift @cols) {
134     # If next entry is { ... } use that for the column info, if not
135     # use an empty hashref
136     my $column_info = ref $cols[0] ? shift(@cols) : {};
137     push(@added, $col) unless exists $columns->{$col};
138     $columns->{$col} = $column_info;
139   }
140   push @{ $self->_ordered_columns }, @added;
141   return $self;
142 }
143
144 *add_column = \&add_columns;
145
146 =head2 has_column
147
148   if ($obj->has_column($col)) { ... }
149
150 Returns 1 if the source has a column of this name, 0 otherwise.
151
152 =cut
153
154 sub has_column {
155   my ($self, $column) = @_;
156   return exists $self->_columns->{$column};
157 }
158
159 =head2 column_info
160
161   my $info = $obj->column_info($col);
162
163 Returns the column metadata hashref for a column. See the description
164 of add_column for information on the contents of the hashref.
165
166 =cut
167
168 sub column_info {
169   my ($self, $column) = @_;
170   $self->throw_exception("No such column $column")
171     unless exists $self->_columns->{$column};
172   #warn $self->{_columns_info_loaded}, "\n";
173   if ( ! $self->_columns->{$column}{data_type}
174        and ! $self->{_columns_info_loaded}
175        and $self->schema and $self->storage )
176   {
177     $self->{_columns_info_loaded}++;
178     my $info;
179     # eval for the case of storage without table
180     eval { $info = $self->storage->columns_info_for($self->from) };
181     unless ($@) {
182       foreach my $col ( keys %{$self->_columns} ) {
183         foreach my $i ( keys %{$info->{$col}} ) {
184             $self->_columns->{$col}{$i} = $info->{$col}{$i};
185         }
186       }
187     }
188   }
189   return $self->_columns->{$column};
190 }
191
192 =head2 columns
193
194   my @column_names = $obj->columns;
195
196 Returns all column names in the order they were declared to add_columns
197
198 =cut
199
200 sub columns {
201   my $self = shift;
202   $self->throw_exception(
203     "columns() is a read-only accessor, did you mean add_columns()?"
204   ) if (@_ > 1);
205   return @{$self->{_ordered_columns}||[]};
206 }
207
208 =head2 set_primary_key
209
210 =over 4
211
212 =item Arguments: (@cols)
213
214 =back
215
216 Defines one or more columns as primary key for this source. Should be
217 called after C<add_columns>.
218
219 Additionally, defines a unique constraint named C<primary>.
220
221 The primary key columns are used by L<DBIx::Class::PK::Auto> to
222 retrieve automatically created values from the database.
223
224 =cut
225
226 sub set_primary_key {
227   my ($self, @cols) = @_;
228   # check if primary key columns are valid columns
229   foreach my $col (@cols) {
230     $self->throw_exception("No such column $col on table " . $self->name)
231       unless $self->has_column($col);
232   }
233   $self->_primaries(\@cols);
234
235   $self->add_unique_constraint(primary => \@cols);
236 }
237
238 =head2 primary_columns
239
240 Read-only accessor which returns the list of primary keys.
241
242 =cut
243
244 sub primary_columns {
245   return @{shift->_primaries||[]};
246 }
247
248 =head2 add_unique_constraint
249
250 Declare a unique constraint on this source. Call once for each unique
251 constraint. Unique constraints are used when you call C<find> on a
252 L<DBIx::Class::ResultSet>, only columns in the constraint are searched,
253
254 e.g.,
255
256   # For UNIQUE (column1, column2)
257   __PACKAGE__->add_unique_constraint(
258     constraint_name => [ qw/column1 column2/ ],
259   );
260
261 =cut
262
263 sub add_unique_constraint {
264   my ($self, $name, $cols) = @_;
265
266   foreach my $col (@$cols) {
267     $self->throw_exception("No such column $col on table " . $self->name)
268       unless $self->has_column($col);
269   }
270
271   my %unique_constraints = $self->unique_constraints;
272   $unique_constraints{$name} = $cols;
273   $self->_unique_constraints(\%unique_constraints);
274 }
275
276 =head2 unique_constraints
277
278 Read-only accessor which returns the list of unique constraints on this source.
279
280 =cut
281
282 sub unique_constraints {
283   return %{shift->_unique_constraints||{}};
284 }
285
286 =head2 from
287
288 Returns an expression of the source to be supplied to storage to specify
289 retrieval from this source; in the case of a database the required FROM clause
290 contents.
291
292 =cut
293
294 =head2 storage
295
296 Returns the storage handle for the current schema.
297
298 See also: L<DBIx::Class::Storage>
299
300 =cut
301
302 sub storage { shift->schema->storage; }
303
304 =head2 add_relationship
305
306   $source->add_relationship('relname', 'related_source', $cond, $attrs);
307
308 The relationship name can be arbitrary, but must be unique for each
309 relationship attached to this result source. 'related_source' should
310 be the name with which the related result source was registered with
311 the current schema. For example:
312
313   $schema->source('Book')->add_relationship('reviews', 'Review', {
314     'foreign.book_id' => 'self.id',
315   });
316
317 The condition C<$cond> needs to be an SQL::Abstract-style
318 representation of the join between the tables. For example, if you're
319 creating a rel from Author to Book,
320
321   { 'foreign.author_id' => 'self.id' }
322
323 will result in the JOIN clause
324
325   author me JOIN book foreign ON foreign.author_id = me.id
326
327 You can specify as many foreign => self mappings as necessary.
328
329 Valid attributes are as follows:
330
331 =over 4
332
333 =item join_type
334
335 Explicitly specifies the type of join to use in the relationship. Any
336 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
337 the SQL command immediately before C<JOIN>.
338
339 =item proxy
340
341 An arrayref containing a list of accessors in the foreign class to proxy in
342 the main class. If, for example, you do the following:
343   
344   CD->might_have(liner_notes => 'LinerNotes', undef, {
345     proxy => [ qw/notes/ ],
346   });
347   
348 Then, assuming LinerNotes has an accessor named notes, you can do:
349
350   my $cd = CD->find(1);
351   $cd->notes('Notes go here'); # set notes -- LinerNotes object is
352                                # created if it doesn't exist
353
354 =item accessor
355
356 Specifies the type of accessor that should be created for the
357 relationship. Valid values are C<single> (for when there is only a single
358 related object), C<multi> (when there can be many), and C<filter> (for
359 when there is a single related object, but you also want the relationship
360 accessor to double as a column accessor). For C<multi> accessors, an
361 add_to_* method is also created, which calls C<create_related> for the
362 relationship.
363
364 =back
365
366 =cut
367
368 sub add_relationship {
369   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
370   $self->throw_exception("Can't create relationship without join condition")
371     unless $cond;
372   $attrs ||= {};
373
374   my %rels = %{ $self->_relationships };
375   $rels{$rel} = { class => $f_source_name,
376                   source => $f_source_name,
377                   cond  => $cond,
378                   attrs => $attrs };
379   $self->_relationships(\%rels);
380
381   return $self;
382
383   # XXX disabled. doesn't work properly currently. skip in tests.
384
385   my $f_source = $self->schema->source($f_source_name);
386   unless ($f_source) {
387     eval "require $f_source_name;";
388     if ($@) {
389       die $@ unless $@ =~ /Can't locate/;
390     }
391     $f_source = $f_source_name->result_source;
392     #my $s_class = ref($self->schema);
393     #$f_source_name =~ m/^${s_class}::(.*)$/;
394     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
395     #$f_source = $self->schema->source($f_source_name);
396   }
397   return unless $f_source; # Can't test rel without f_source
398
399   eval { $self->resolve_join($rel, 'me') };
400
401   if ($@) { # If the resolve failed, back out and re-throw the error
402     delete $rels{$rel}; #
403     $self->_relationships(\%rels);
404     $self->throw_exception("Error creating relationship $rel: $@");
405   }
406   1;
407 }
408
409 =head2 relationships
410
411 Returns all valid relationship names for this source
412
413 =cut
414
415 sub relationships {
416   return keys %{shift->_relationships};
417 }
418
419 =head2 relationship_info
420
421 =over 4
422
423 =item Arguments: ($relname)
424
425 =back
426
427 Returns the relationship information for the specified relationship name
428
429 =cut
430
431 sub relationship_info {
432   my ($self, $rel) = @_;
433   return $self->_relationships->{$rel};
434 }
435
436 =head2 has_relationship
437
438 =over 4
439
440 =item Arguments: ($rel)
441
442 =back
443
444 Returns 1 if the source has a relationship of this name, 0 otherwise.
445
446 =cut
447
448 sub has_relationship {
449   my ($self, $rel) = @_;
450   return exists $self->_relationships->{$rel};
451 }
452
453 =head2 resolve_join
454
455 =over 4
456
457 =item Arguments: ($relation)
458
459 =back
460
461 Returns the join structure required for the related result source
462
463 =cut
464
465 sub resolve_join {
466   my ($self, $join, $alias, $seen) = @_;
467   $seen ||= {};
468   if (ref $join eq 'ARRAY') {
469     return map { $self->resolve_join($_, $alias, $seen) } @$join;
470   } elsif (ref $join eq 'HASH') {
471     return
472       map {
473         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
474         ($self->resolve_join($_, $alias, $seen),
475           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
476       } keys %$join;
477   } elsif (ref $join) {
478     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
479   } else {
480     my $count = ++$seen->{$join};
481     #use Data::Dumper; warn Dumper($seen);
482     my $as = ($count > 1 ? "${join}_${count}" : $join);
483     my $rel_info = $self->relationship_info($join);
484     $self->throw_exception("No such relationship ${join}") unless $rel_info;
485     my $type = $rel_info->{attrs}{join_type} || '';
486     return [ { $as => $self->related_source($join)->from,
487                -join_type => $type },
488              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
489   }
490 }
491
492 =head2 resolve_condition
493
494 =over 4
495
496 =item Arguments: ($cond, $as, $alias|$object)
497
498 =back
499
500 Resolves the passed condition to a concrete query fragment. If given an alias,
501 returns a join condition; if given an object, inverts that object to produce
502 a related conditional from that object.
503
504 =cut
505
506 sub resolve_condition {
507   my ($self, $cond, $as, $for) = @_;
508   #warn %$cond;
509   if (ref $cond eq 'HASH') {
510     my %ret;
511     while (my ($k, $v) = each %{$cond}) {
512       # XXX should probably check these are valid columns
513       $k =~ s/^foreign\.// ||
514         $self->throw_exception("Invalid rel cond key ${k}");
515       $v =~ s/^self\.// ||
516         $self->throw_exception("Invalid rel cond val ${v}");
517       if (ref $for) { # Object
518         #warn "$self $k $for $v";
519         $ret{$k} = $for->get_column($v);
520         #warn %ret;
521       } elsif (ref $as) { # reverse object
522         $ret{$v} = $as->get_column($k);
523       } else {
524         $ret{"${as}.${k}"} = "${for}.${v}";
525       }
526     }
527     return \%ret;
528   } elsif (ref $cond eq 'ARRAY') {
529     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
530   } else {
531    die("Can't handle this yet :(");
532   }
533 }
534
535 =head2 resolve_prefetch
536
537 =over 4
538
539 =item Arguments: (hashref/arrayref/scalar)
540
541 =back
542
543 Accepts one or more relationships for the current source and returns an
544 array of column names for each of those relationships. Column names are
545 prefixed relative to the current source, in accordance with where they appear
546 in the supplied relationships. Examples:
547
548   my $source = $schema->resultset('Tag')->source;
549   @columns = $source->resolve_prefetch( { cd => 'artist' } );
550
551   # @columns =
552   #(
553   #  'cd.cdid',
554   #  'cd.artist',
555   #  'cd.title',
556   #  'cd.year',
557   #  'cd.artist.artistid',
558   #  'cd.artist.name'
559   #)
560
561   @columns = $source->resolve_prefetch( qw[/ cd /] );
562
563   # @columns =
564   #(
565   #   'cd.cdid',
566   #   'cd.artist',
567   #   'cd.title',
568   #   'cd.year'
569   #)
570
571   $source = $schema->resultset('CD')->source;
572   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
573
574   # @columns =
575   #(
576   #  'artist.artistid',
577   #  'artist.name',
578   #  'producer.producerid',
579   #  'producer.name'
580   #)
581
582 =cut
583
584 sub resolve_prefetch {
585   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
586   $seen ||= {};
587   #$alias ||= $self->name;
588   #warn $alias, Dumper $pre;
589   if( ref $pre eq 'ARRAY' ) {
590     return
591       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
592         @$pre;
593   }
594   elsif( ref $pre eq 'HASH' ) {
595     my @ret =
596     map {
597       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
598       $self->related_source($_)->resolve_prefetch(
599                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
600     } keys %$pre;
601     #die Dumper \@ret;
602     return @ret;
603   }
604   elsif( ref $pre ) {
605     $self->throw_exception(
606       "don't know how to resolve prefetch reftype ".ref($pre));
607   }
608   else {
609     my $count = ++$seen->{$pre};
610     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
611     my $rel_info = $self->relationship_info( $pre );
612     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
613       unless $rel_info;
614     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
615     my $rel_source = $self->related_source($pre);
616
617     if (exists $rel_info->{attrs}{accessor}
618          && $rel_info->{attrs}{accessor} eq 'multi') {
619       $self->throw_exception(
620         "Can't prefetch has_many ${pre} (join cond too complex)")
621         unless ref($rel_info->{cond}) eq 'HASH';
622       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
623                     keys %{$rel_info->{cond}};
624       $collapse->{"${as_prefix}${pre}"} = \@key;
625       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
626                    ? @{$rel_info->{attrs}{order_by}}
627                    : (defined $rel_info->{attrs}{order_by}
628                        ? ($rel_info->{attrs}{order_by})
629                        : ()));
630       push(@$order, map { "${as}.$_" } (@key, @ord));
631     }
632
633     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
634       $rel_source->columns;
635     #warn $alias, Dumper (\@ret);
636     #return @ret;
637   }
638 }
639
640 =head2 related_source
641
642 =over 4
643
644 =item Arguments: ($relname)
645
646 =back
647
648 Returns the result source object for the given relationship
649
650 =cut
651
652 sub related_source {
653   my ($self, $rel) = @_;
654   if( !$self->has_relationship( $rel ) ) {
655     $self->throw_exception("No such relationship '$rel'");
656   }
657   return $self->schema->source($self->relationship_info($rel)->{source});
658 }
659
660 =head2 related_class
661
662 =over 4
663
664 =item Arguments: ($relname)
665
666 =back
667
668 Returns the class object for the given relationship
669
670 =cut
671
672 sub related_class {
673   my ($self, $rel) = @_;
674   if( !$self->has_relationship( $rel ) ) {
675     $self->throw_exception("No such relationship '$rel'");
676   }
677   return $self->schema->class($self->relationship_info($rel)->{source});
678 }
679
680 =head2 resultset
681
682 Returns a resultset for the given source. This will initially be created
683 on demand by calling
684
685   $self->resultset_class->new($self, $self->resultset_attributes)
686
687 but is cached from then on unless resultset_class changes.
688
689 =head2 resultset_class
690
691 Set the class of the resultset, this is useful if you want to create your
692 own resultset methods. Create your own class derived from
693 L<DBIx::Class::ResultSet>, and set it here.
694
695 =head2 resultset_attributes
696
697 Specify here any attributes you wish to pass to your specialised resultset.
698
699 =cut
700
701 sub resultset {
702   my $self = shift;
703   $self->throw_exception(
704     'resultset does not take any arguments. If you want another resultset, '.
705     'call it on the schema instead.'
706   ) if scalar @_;
707   return $self->{_resultset}
708     if ref $self->{_resultset} eq $self->resultset_class;
709   return $self->{_resultset} = $self->resultset_class->new(
710     $self, $self->{resultset_attributes}
711   );
712 }
713
714 =head2 throw_exception
715
716 See throw_exception in L<DBIx::Class::Schema>.
717
718 =cut
719
720 sub throw_exception {
721   my $self = shift;
722   if (defined $self->schema) {
723     $self->schema->throw_exception(@_);
724   } else {
725     croak(@_);
726   }
727 }
728
729
730 =head1 AUTHORS
731
732 Matt S. Trout <mst@shadowcatsystems.co.uk>
733
734 =head1 LICENSE
735
736 You may distribute this code under the same terms as Perl itself.
737
738 =cut
739