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