Remove dep on signatures
[dbsrgits/DBIx-Class-ResultSource-MultipleTableInheritance.git] / lib / DBIx / Class / ResultSource / MultipleTableInheritance.pm
1 package DBIx::Class::ResultSource::MultipleTableInheritance;
2
3 use strict;
4 use warnings;
5 use parent qw(DBIx::Class::ResultSource::View);
6 use Method::Signatures::Simple;
7 use Carp::Clan qw/^DBIx::Class/;
8 use aliased 'DBIx::Class::ResultSource::Table';
9 use aliased 'DBIx::Class::ResultClass::HashRefInflator';
10 use String::TT qw(strip tt);
11 use Scalar::Util qw(blessed);
12 use namespace::autoclean;
13
14 our $VERSION = 0.01;
15
16 __PACKAGE__->mk_group_accessors(simple => qw(parent_source additional_parents));
17
18 # how this works:
19 #
20 # On construction, we hook $self->result_class->result_source_instance
21 # if present to get the superclass' source object
22 #
23 # When attached to a schema, we need to add sources to that schema with
24 # appropriate relationships for the foreign keys so the concrete tables
25 # get generated
26 #
27 # We also generate our own view definition using this class' concrete table
28 # and the view for the superclass, and stored procedures for the insert,
29 # update and delete operations on this view.
30 #
31 # deploying the postgres rules through SQLT may be a pain though.
32
33 method new ($class: @args) {
34   my $new = $class->next::method(@args);
35   my $rc = $new->result_class;
36   if (my $meth = $rc->can('result_source_instance')) {
37     my $source = $rc->$meth;
38     if ($source->result_class ne $new->result_class
39         && $new->result_class->isa($source->result_class)) {
40       $new->parent_source($source);
41     }
42   }
43   return $new;
44 }
45
46 method add_additional_parents (@classes) {
47   foreach my $class (@classes) {
48     Class::C3::Componentised->ensure_class_loaded($class);
49     $self->add_additional_parent(
50       $class->result_source_instance
51     );
52   }
53 }
54
55 method add_additional_parent ($source) {
56   my ($our_pk, $their_pk) = map {
57     join('|',sort $_->primary_columns)
58   } ($self, $source);
59
60   confess "Can't attach additional parent ${\$source->name} - it has different PKs ($their_pk versus our $our_pk)"
61     unless $their_pk eq $our_pk;
62   $self->additional_parents([
63     @{$self->additional_parents||[]}, $source
64   ]);
65   $self->add_columns(
66     map {
67       $_ => # put the extra key first to default it
68       { originally_defined_in => $source->name, %{$source->column_info($_)}, },
69     } grep !$self->has_column($_), $source->columns
70   );
71   foreach my $rel ($source->relationships) {
72     my $rel_info = $source->relationship_info($rel);
73     $self->add_relationship(
74       $rel, $rel_info->{source}, $rel_info->{cond},
75       # extra key first to default it
76       {originally_defined_in => $source->name, %{$rel_info->{attrs}}},
77     );
78   }
79   { no strict 'refs';
80     push(@{$self->result_class.'::ISA'}, $source->result_class);
81   }
82 }
83
84 method _source_by_name ($name) {
85   my $schema = $self->schema;
86   my ($source) =
87     grep { $_->name eq $name }
88       map $schema->source($_), $schema->sources;
89   confess "Couldn't find attached source for parent $name - did you use load_classes? This module is only compatible with load_namespaces"
90     unless $source;
91   return $source;
92 }
93
94 method schema (@args) {
95   my $ret = $self->next::method(@args);
96   if (@args) {
97     if ($self->parent_source) {
98       my $parent_name = $self->parent_source->name;
99       $self->parent_source($self->_source_by_name($parent_name));
100     }
101     $self->additional_parents([
102       map { $self->_source_by_name($_->name) }
103       @{$self->additional_parents||[]}
104     ]);
105   }
106   return $ret;
107 }
108
109 method attach_additional_sources () {
110   my $raw_name = $self->raw_source_name;
111   my $schema = $self->schema;
112
113   # if the raw source is already present we can assume we're done
114   return if grep { $_ eq $raw_name } $schema->sources;
115
116   # our parent should've been registered already actually due to DBIC
117   # attaching subclass sources later in load_namespaces
118
119   my $parent;
120   if ($self->parent_source) {
121       my $parent_name = $self->parent_source->name;
122     ($parent) =
123       grep { $_->name eq $parent_name }
124         map $schema->source($_), $schema->sources;
125     confess "Couldn't find attached source for parent $parent_name - did you use load_classes? This module is only compatible with load_namespaces"
126       unless $parent;
127     $self->parent_source($parent); # so our parent is the one in this schema
128   }
129
130   # create the raw table source
131
132   my $table = Table->new({ name => $self->raw_table_name });
133
134   # we don't need to add the PK cols explicitly if we're the root table
135   # since they'll get added below
136
137   my %pk_join;
138
139   if ($parent) {
140     foreach my $pri ($self->primary_columns) {
141       my %info = %{$self->column_info($pri)};
142       delete @info{qw(is_auto_increment sequence auto_nextval)};
143       $table->add_column($pri => \%info);
144       $pk_join{"foreign.${pri}"} = "self.${pri}";
145     }
146     # have to use source name lookups rather than result class here
147     # because we don't actually have a result class on the raw sources
148     $table->add_relationship('parent', $parent->raw_source_name, \%pk_join);
149     $self->deploy_depends_on->{$parent->result_class} = 1;
150   }
151
152   foreach my $add (@{$self->additional_parents||[]}) {
153     $table->add_relationship(
154       'parent_'.$add->name, $add->source_name, \%pk_join
155     );
156     $self->deploy_depends_on->{$add->result_class} = 1 if $add->isa('DBIx::Class::ResultSource::View');
157   }
158   $table->add_columns(
159     map { ($_ => { %{$self->column_info($_)} }) }
160       grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
161         $self->columns
162   );
163   $table->set_primary_key($self->primary_columns);
164
165   # we need to copy our rels to the raw object as well
166   # note that ->add_relationship on a source object doesn't create an
167   # accessor so we can leave that part in the attributes
168
169   # if the other side is a table then we need to copy any rels it has
170   # back to us, as well, so that they point at the raw table. if the
171   # other side is an MTI view then we need to create the rels to it to
172   # point at -its- raw table; we don't need to worry about backrels because
173   # it's going to run this method too (and its raw source might not exist
174   # yet so we can't, anyway)
175
176   foreach my $rel ($self->relationships) {
177     my $rel_info = $self->relationship_info($rel);
178
179     # if we got this from the superclass, -its- raw table will nail this.
180     # if we got it from an additional parent, it's its problem.
181     next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;
182
183     my $f_source = $schema->source($rel_info->{source});
184
185     # __PACKAGE__ is correct here because subclasses should be caught
186
187     my $one_of_us = $f_source->isa(__PACKAGE__);
188
189     my $f_source_name = $f_source->${\
190                         ($one_of_us ? 'raw_source_name' : 'source_name')
191                       };
192
193     $table->add_relationship(
194       '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
195     );
196
197     unless ($one_of_us) {
198       my $reverse = do {
199         # we haven't been registered yet, so reverse_ cries
200         # XXX this is evil and will probably break eventually
201         local @{$schema->source_registrations}
202                {map $self->$_, qw(source_name result_class)}
203           = ($self, $self);
204         $self->reverse_relationship_info($rel);
205       };
206       foreach my $rev_rel (keys %$reverse) {
207         $f_source->add_relationship(
208           '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
209         );
210       }
211     }
212   }
213
214   $schema->register_source($raw_name => $table);
215 }
216
217 method set_primary_key (@args) {
218   if ($self->parent_source) {
219     confess "Can't set primary key on a subclass";
220   }
221   return $self->next::method(@args);
222 }
223
224 method set_sequence ($table_name, @pks) {
225   return $table_name . '_' . join('_',@pks) . '_' . 'seq';
226 }
227
228 method raw_source_name () {
229   my $base = $self->source_name;
230   confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
231     unless $base;
232   return 'Raw::'.$base;
233 }
234
235 method raw_table_name () {
236   return '_'.$self->name;
237 }
238
239 method add_columns (@args) {
240   my $ret = $self->next::method(@args);
241   $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
242   return $ret;
243 }
244
245 method add_relationship ($name, $f_source, $cond, $attrs) {
246   $self->next::method(
247     $name, $f_source, $cond,
248     { originally_defined_in => $self->name, %{$attrs||{}}, }
249   );
250 }
251
252 BEGIN {
253
254   sub argify {
255     my @names = @_;
256     map '_' . $_, @names;
257   }
258
259   sub qualify_with {
260     my $source = shift;
261     my @names  = @_;
262     my $name   = blessed($source) ? $source->name : $source;
263     map join( '.', $name, $_ ), @names;
264   }
265
266   sub body_cols {
267     my $source = shift;
268     my %pk;
269     @pk{ $source->primary_columns } = ();
270     map +{ %{ $source->column_info($_) }, name => $_ },
271       grep !exists $pk{$_}, $source->columns;
272   }
273
274   sub pk_cols {
275     my $source = shift;
276     map +{ %{ $source->column_info($_) }, name => $_ },
277       $source->primary_columns;
278   }
279
280   sub names_of { my @cols = @_; map $_->{name}, @cols }
281
282   sub function_body {
283     my ( $name, $args, $body_parts ) = @_;
284     my $arglist =
285       join( ', ', map "_${\$_->{name}} ${\uc($_->{data_type})}", @$args );
286     my $body = join( "\n", '', map "          $_;", @$body_parts );
287     return strip tt q{
288       CREATE OR REPLACE FUNCTION [% name %]
289         ([% arglist %])
290         RETURNS VOID AS $function$
291         BEGIN
292           [%- body %]
293         END;
294       $function$ LANGUAGE plpgsql;
295     };
296   }
297 }
298
299 BEGIN {
300
301   sub arg_hash {
302     my $source = shift;
303     map +( $_ => \( argify $_) ), names_of body_cols $source;
304   }
305
306   sub rule_body {
307     my ( $on, $to, $oldlist, $newlist ) = @_;
308     my $arglist = join( ', ',
309       ( qualify_with 'OLD', names_of @$oldlist ),
310       ( qualify_with 'NEW', names_of @$newlist ),
311     );
312     $to = $to->name if blessed($to);
313     return strip tt q{
314       CREATE RULE _[% to %]_[% on %]_rule AS
315         ON [% on | upper %] TO [% to %]
316         DO INSTEAD (
317           SELECT [% to %]_[% on %]([% arglist %])
318         );
319     };
320   }
321 }
322
323 method root_table () {
324   $self->parent_source
325     ? $self->parent_source->root_table
326     : $self->schema->source($self->raw_source_name)
327 }
328
329 method view_definition () {
330   my $schema = $self->schema;
331   confess "Can't generate view without connected schema, sorry"
332     unless $schema && $schema->storage;
333   my $sqla = $schema->storage->sql_maker;
334   my $table = $self->schema->source($self->raw_source_name);
335   my $super_view = $self->parent_source;
336   my @all_parents = my @other_parents = @{$self->additional_parents||[]};
337   push(@all_parents, $super_view) if defined($super_view);
338   my @sources = ($table, @all_parents);
339   my @body_cols = map body_cols($_), @sources;
340
341   # Order body_cols to match the columns order.
342   # Must match or you get typecast errors.
343   my %body_cols = map { $_->{name} => $_ } @body_cols;
344   @body_cols =
345     map { $body_cols{$_} }
346     grep { defined $body_cols{$_} }
347     $self->columns;
348   my @pk_cols = pk_cols $self;
349
350   # Grab sequence from root table. Only works with one PK named id...
351   # TBD: Fix this so it's more flexible.
352   for my $pk_col (@pk_cols) {
353     $self->columns_info->{ $pk_col->{name} }->{sequence} =
354       $self->root_table->name . '_id_seq';
355   }
356
357   # SELECT statement
358
359   my $am_root = !($super_view || @other_parents);
360
361   my $select = $sqla->select(
362     ($am_root
363       ? ($table->name)
364       : ([   # FROM _tbl _tbl
365            { $table->name => $table->name },
366            map {
367              my $parent = $_;
368              [ # JOIN view view
369                { $parent->name => $parent->name },
370                # ON _tbl.id = view.id
371                { map +(qualify_with($parent, $_), qualify_with($table, $_)),
372                    names_of @pk_cols }
373              ]
374            } @all_parents
375          ])
376       ),
377     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
378   ).';';
379
380   my ($now, @next) = grep defined, $super_view, $table, @other_parents;
381
382   # INSERT function
383
384   # NOTE: this assumes a single PK col called id with a sequence somewhere
385   # but nothing else -should- so fixing this should make everything work
386   my $insert_func =
387     function_body
388       $self->name.'_insert',
389       \@body_cols,
390       [
391         $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
392           $now->name,
393           { arg_hash $now },
394         ),
395         (map {
396           $sqla->insert( # INSERT INTO parent (id, ...)
397                          #   VALUES (currval('_root_tbl_id_seq'), ...)
398             $_->name,
399             {
400               (arg_hash $_),
401               id => \"currval('${\$self->root_table->name}_id_seq')",
402             }
403           )
404         } @next)
405       ];
406
407   # note - similar to arg_hash but not quite enough to share code sanely
408   my $pk_where = { # id = _id AND id2 = _id2 ...
409     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
410   };
411
412   # UPDATE function
413
414   my $update_func =
415     function_body
416       $self->name.'_update',
417       [ @pk_cols, @body_cols ],
418       [ map $sqla->update(
419           $_->name, # UPDATE foo
420           { arg_hash $_ }, # SET a = _a
421           $pk_where,
422         ), @sources
423       ];
424
425   # DELETE function
426
427   my $delete_func =
428     function_body
429       $self->name.'_delete',
430       [ @pk_cols ],
431       [ map $sqla->delete($_->name, $pk_where), @sources ];
432
433   my @rules = (
434     (rule_body insert => $self, [], \@body_cols),
435     (rule_body update => $self, \@pk_cols, \@body_cols),
436     (rule_body delete => $self, \@pk_cols, []),
437   );
438   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
439 }
440
441 1;
442
443 __END__
444
445 =head1 NAME
446
447 DBIx::Class::ResultSource::MultipleTableInheritance
448 Use multiple tables to define your classes
449
450 =head1 NOTICE
451
452 This only works with PostgreSQL at the moment. It has been tested with
453 PostgreSQL 9.0 and 9.1 beta.
454
455 There is one additional caveat: the "parent" result classes that you
456 defined with this resultsource must have one primary column and it must
457 be named "id."
458
459 =head1 SYNOPSIS
460
461     {
462         package Cafe::Result::Coffee;
463
464         use strict;
465         use warnings;
466         use parent 'DBIx::Class::Core';
467         use aliased 'DBIx::Class::ResultSource::MultipleTableInheritance'
468             => 'MTI';
469
470         __PACKAGE__->table_class(MTI);
471         __PACKAGE__->table('coffee');
472         __PACKAGE__->add_columns(
473             "id", { data_type => "integer" },
474             "flavor", {
475                 data_type => "text",
476                 default_value => "good" },
477         );
478
479         __PACKAGE__->set_primary_key("id");
480
481         1;
482     }
483
484     {
485         package Cafe::Result::Sumatra;
486
487         use parent 'Cafe::Result::Coffee';
488
489         __PACKAGE__->table('sumatra');
490
491         __PACKAGE__->add_columns( "aroma",
492             { data_type => "text" }
493         );
494
495         1;
496     }
497
498     ...
499
500     my $schema = Cafe->connect($dsn,$user,$pass);
501
502     my $cup = $schema->resultset('Sumatra');
503
504     print STDERR Dwarn $cup->result_source->columns;
505
506         "id"
507         "flavor"
508         "aroma"
509         ..
510
511 Inherit from this package and you can make a resultset class from a view, but
512 that's more than a little bit misleading: the result is B<transparently
513 writable>.
514
515 This is accomplished through the use of stored procedures that map changes
516 written to the view to changes to the underlying concrete tables.
517
518 =head1 WHY?
519
520 In many applications, many classes are subclasses of others. Let's say you
521 have this schema:
522
523     # Conceptual domain model
524
525     class User {
526         has id,
527         has name,
528         has password
529     }
530
531     class Investor {
532         has id,
533         has name,
534         has password,
535         has dollars
536     }
537
538 That's redundant. Hold on a sec...
539
540     class User {
541         has id,
542         has name,
543         has password
544     }
545
546     class Investor extends User {
547         has dollars
548     }
549
550 Good idea, but how to put this into code?
551
552 One far-too common and absolutely horrendous solution is to have a "checkbox"
553 in your database: a nullable "investor" column, which entails a nullable
554 "dollars" column, in the user table.
555
556     create table "user" (
557         "id" integer not null primary key autoincrement,
558         "name" text not null,
559         "password" text not null,
560         "investor" tinyint(1),
561         "dollars" integer
562     );
563
564 Let's not discuss that further.
565
566 A second, better, solution is to break out the two tables into user and
567 investor:
568
569     create table "user" (
570         "id" integer not null primary key autoincrement,
571         "name" text not null,
572         "password" text not null
573     );
574
575     create table "investor" (
576         "id" integer not null references user("id"),
577         "dollars" integer
578     );
579
580 So that investor's PK is just an FK to the user. We can clearly see the class
581 hierarchy here, in which investor is a subclass of user. In DBIx::Class
582 applications, this second strategy looks like:
583
584     my $user_rs = $schema->resultset('User');
585     my $new_user = $user_rs->create(
586         name => $args->{name},
587         password => $args->{password},
588     );
589
590     ...
591
592     my $new_investor = $schema->resultset('Investor')->create(
593         id => $new_user->id,
594         dollars => $args->{dollars},
595     );
596
597 One can cope well with the second strategy, and it seems to be the most popular
598 smart choice.
599
600 =head1 HOW?
601
602 There is a third strategy implemented here. Make the database do more of the
603 work: hide the nasty bits so we don't have to handle them unless we really want
604 to. It'll save us some typing and it'll make for more expressive code. What if
605 we could do this:
606
607     my $new_investor = $schema->resultset('Investor')->create(
608         name => $args->{name},
609         password => $args->{password},
610         dollars => $args->{dollars},
611     );
612
613 And have it Just Work? The user...
614
615     {
616         name => $args->{name},
617         password => $args->{password},
618     }
619
620 should be created behind the scenes, and the use of either user or investor
621 in your code should require no special handling. Deleting and updating
622 $new_investor should also delete or update the user row.
623
624 It does. User and investor are both views, their concrete tables abstracted
625 away behind a set of rules and triggers. You would expect the above DBIC
626 create statement to look like this in SQL:
627
628     INSERT INTO investor ("name","password","dollars") VALUES (...);
629
630 But using MTI, it is really this:
631
632     INSERT INTO _user_table ("username","password") VALUES (...);
633     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
634
635 For deletes, the triggers fire in reverse, to preserve referential integrity
636 (foreign key constraints). For instance:
637
638    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
639    $investor->delete;
640
641 Becomes:
642
643     DELETE FROM _investor_table WHERE ("id" = ?);
644     DELETE FROM _user_table WHERE ("id" = ?);
645
646
647 =head1 METHODS
648
649 =over
650
651 =item new
652
653
654 MTI find the parents, if any, of your resultset class and adds them to the
655 list of parent_sources for the table.
656
657
658 =item add_additional_parents
659
660
661 Continuing with coffee:
662
663     __PACKAGE__->result_source_instance->add_additional_parents(
664         qw/
665             MyApp::Schema::Result::Beverage
666             MyApp::Schema::Result::Liquid
667         /
668     );
669
670 This just lets you manually add additional parents beyond the ones MTI finds.
671
672 =item add_additional_parent
673
674     __PACKAGE__->result_source_instance->add_additional_parent(
675             MyApp::Schema::Result::Beverage
676     );
677
678 You can also add just one.
679
680 =item attach_additional_sources
681
682 MTI takes the parents' sources and relationships, creates a new
683 DBIx::Class::Table object from them, and registers this as a new, raw, source
684 in the schema, e.g.,
685
686     use MyApp::Schema;
687
688     print STDERR map { "$_\n" } MyApp::Schema->sources;
689
690     # Coffee
691     # Beverage
692     # Liquid
693     # Sumatra
694     # Raw::Sumatra
695
696 Raw::Sumatra will be used to generate the view.
697
698 =item view_definition
699
700 This takes the raw table and generates the view (and stored procedures) you will use.
701
702 =back
703
704 =head1 AUTHOR
705
706 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
707
708 =head2 CONTRIBUTORS
709
710 Amiri Barksdale, E<lt>amiri@roosterpirates.comE<gt>
711
712 =head1 COPYRIGHT
713
714 Copyright (c) 2011 the DBIx::Class::ResultSource::MultipleTableInheritance
715 L</AUTHOR> and L</CONTRIBUTORS> as listed above.
716
717 =head1 LICENSE
718
719 This library is free software; you can redistribute it and/or modify
720 it under the same terms as Perl itself.
721
722 =head1 SEE ALSO
723
724 L<DBIx::Class>
725 L<DBIx::Class::ResultSource>
726
727 =cut