Add more DBs with which this has been tested
[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 -also => [qw/argify qualify_with body_cols pk_cols names_of function_body arg_hash rule_body/];
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   # helper routines
255
256   sub argify {
257     my @names = @_;
258     map '_' . $_, @names;
259   }
260
261   sub qualify_with {
262     my $source = shift;
263     my @names  = @_;
264     my $name   = blessed($source) ? $source->name : $source;
265     map join( '.', $name, $_ ), @names;
266   }
267
268   sub body_cols {
269     my $source = shift;
270     my %pk;
271     @pk{ $source->primary_columns } = ();
272     map +{ %{ $source->column_info($_) }, name => $_ },
273       grep !exists $pk{$_}, $source->columns;
274   }
275
276   sub pk_cols {
277     my $source = shift;
278     map +{ %{ $source->column_info($_) }, name => $_ },
279       $source->primary_columns;
280   }
281
282   sub names_of { my @cols = @_; map $_->{name}, @cols }
283
284   sub function_body {
285     my ( $name, $args, $body_parts ) = @_;
286     my $arglist =
287       join( ', ', map "_${\$_->{name}} ${\uc($_->{data_type})}", @$args );
288     my $body = join( "\n", '', map "          $_;", @$body_parts );
289     return strip tt q{
290       CREATE OR REPLACE FUNCTION [% name %]
291         ([% arglist %])
292         RETURNS VOID AS $function$
293         BEGIN
294           [%- body %]
295         END;
296       $function$ LANGUAGE plpgsql;
297     };
298   }
299 }
300
301 BEGIN {
302
303   sub arg_hash {
304     my $source = shift;
305     map +( $_ => \( argify $_) ), names_of body_cols $source;
306   }
307
308   sub rule_body {
309     my ( $on, $to, $oldlist, $newlist ) = @_;
310     my $arglist = join( ', ',
311       ( qualify_with 'OLD', names_of @$oldlist ),
312       ( qualify_with 'NEW', names_of @$newlist ),
313     );
314     $to = $to->name if blessed($to);
315     return strip tt q{
316       CREATE RULE _[% to %]_[% on %]_rule AS
317         ON [% on | upper %] TO [% to %]
318         DO INSTEAD (
319           SELECT [% to %]_[% on %]([% arglist %])
320         );
321     };
322   }
323 }
324
325 method root_table () {
326   $self->parent_source
327     ? $self->parent_source->root_table
328     : $self->schema->source($self->raw_source_name)
329 }
330
331 method view_definition () {
332   my $schema = $self->schema;
333   confess "Can't generate view without connected schema, sorry"
334     unless $schema && $schema->storage;
335   my $sqla = $schema->storage->sql_maker;
336   my $table = $self->schema->source($self->raw_source_name);
337   my $super_view = $self->parent_source;
338   my @all_parents = my @other_parents = @{$self->additional_parents||[]};
339   push(@all_parents, $super_view) if defined($super_view);
340   my @sources = ($table, @all_parents);
341   my @body_cols = map body_cols($_), @sources;
342
343   # Order body_cols to match the columns order.
344   # Must match or you get typecast errors.
345   my %body_cols = map { $_->{name} => $_ } @body_cols;
346   @body_cols =
347     map { $body_cols{$_} }
348     grep { defined $body_cols{$_} }
349     $self->columns;
350   my @pk_cols = pk_cols $self;
351
352   # Grab sequence from root table. Only works with one PK named id...
353   # TBD: Fix this so it's more flexible.
354   for my $pk_col (@pk_cols) {
355     $self->columns_info->{ $pk_col->{name} }->{sequence} =
356       $self->root_table->name . '_id_seq';
357   }
358
359   # SELECT statement
360
361   my $am_root = !($super_view || @other_parents);
362
363   my $select = $sqla->select(
364     ($am_root
365       ? ($table->name)
366       : ([   # FROM _tbl _tbl
367            { $table->name => $table->name },
368            map {
369              my $parent = $_;
370              [ # JOIN view view
371                { $parent->name => $parent->name },
372                # ON _tbl.id = view.id
373                { map +(qualify_with($parent, $_), qualify_with($table, $_)),
374                    names_of @pk_cols }
375              ]
376            } @all_parents
377          ])
378       ),
379     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
380   ).';';
381
382   my ($now, @next) = grep defined, $super_view, $table, @other_parents;
383
384   # INSERT function
385
386   # NOTE: this assumes a single PK col called id with a sequence somewhere
387   # but nothing else -should- so fixing this should make everything work
388   my $insert_func =
389     function_body
390       $self->name.'_insert',
391       \@body_cols,
392       [
393         $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
394           $now->name,
395           { arg_hash $now },
396         ),
397         (map {
398           $sqla->insert( # INSERT INTO parent (id, ...)
399                          #   VALUES (currval('_root_tbl_id_seq'), ...)
400             $_->name,
401             {
402               (arg_hash $_),
403               id => \"currval('${\$self->root_table->name}_id_seq')",
404             }
405           )
406         } @next)
407       ];
408
409   # note - similar to arg_hash but not quite enough to share code sanely
410   my $pk_where = { # id = _id AND id2 = _id2 ...
411     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
412   };
413
414   # UPDATE function
415
416   my $update_func =
417     function_body
418       $self->name.'_update',
419       [ @pk_cols, @body_cols ],
420       [ map $sqla->update(
421           $_->name, # UPDATE foo
422           { arg_hash $_ }, # SET a = _a
423           $pk_where,
424         ), @sources
425       ];
426
427   # DELETE function
428
429   my $delete_func =
430     function_body
431       $self->name.'_delete',
432       [ @pk_cols ],
433       [ map $sqla->delete($_->name, $pk_where), @sources ];
434
435   my @rules = (
436     (rule_body insert => $self, [], \@body_cols),
437     (rule_body update => $self, \@pk_cols, \@body_cols),
438     (rule_body delete => $self, \@pk_cols, []),
439   );
440   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
441 }
442
443 1;
444
445 __END__
446
447 =head1 NAME
448
449 DBIx::Class::ResultSource::MultipleTableInheritance
450 Use multiple tables to define your classes
451
452 =head1 NOTICE
453
454 This only works with PostgreSQL at the moment. It has been tested with
455 PostgreSQL 9.0, 9.1 beta, and 9.1.
456
457 There is one additional caveat: the "parent" result classes that you
458 defined with this resultsource must have one primary column and it must
459 be named "id."
460
461 =head1 SYNOPSIS
462
463     {
464         package Cafe::Result::Coffee;
465
466         use strict;
467         use warnings;
468         use parent 'DBIx::Class::Core';
469         use aliased 'DBIx::Class::ResultSource::MultipleTableInheritance'
470             => 'MTI';
471
472         __PACKAGE__->table_class(MTI);
473         __PACKAGE__->table('coffee');
474         __PACKAGE__->add_columns(
475             "id", { data_type => "integer" },
476             "flavor", {
477                 data_type => "text",
478                 default_value => "good" },
479         );
480
481         __PACKAGE__->set_primary_key("id");
482
483         1;
484     }
485
486     {
487         package Cafe::Result::Sumatra;
488
489         use parent 'Cafe::Result::Coffee';
490
491         __PACKAGE__->table('sumatra');
492
493         __PACKAGE__->add_columns( "aroma",
494             { data_type => "text" }
495         );
496
497         1;
498     }
499
500     ...
501
502     my $schema = Cafe->connect($dsn,$user,$pass);
503
504     my $cup = $schema->resultset('Sumatra');
505
506     print STDERR Dwarn $cup->result_source->columns;
507
508         "id"
509         "flavor"
510         "aroma"
511         ..
512
513 Inherit from this package and you can make a resultset class from a view, but
514 that's more than a little bit misleading: the result is B<transparently
515 writable>.
516
517 This is accomplished through the use of stored procedures that map changes
518 written to the view to changes to the underlying concrete tables.
519
520 =head1 WHY?
521
522 In many applications, many classes are subclasses of others. Let's say you
523 have this schema:
524
525     # Conceptual domain model
526
527     class User {
528         has id,
529         has name,
530         has password
531     }
532
533     class Investor {
534         has id,
535         has name,
536         has password,
537         has dollars
538     }
539
540 That's redundant. Hold on a sec...
541
542     class User {
543         has id,
544         has name,
545         has password
546     }
547
548     class Investor extends User {
549         has dollars
550     }
551
552 Good idea, but how to put this into code?
553
554 One far-too common and absolutely horrendous solution is to have a "checkbox"
555 in your database: a nullable "investor" column, which entails a nullable
556 "dollars" column, in the user table.
557
558     create table "user" (
559         "id" integer not null primary key autoincrement,
560         "name" text not null,
561         "password" text not null,
562         "investor" tinyint(1),
563         "dollars" integer
564     );
565
566 Let's not discuss that further.
567
568 A second, better, solution is to break out the two tables into user and
569 investor:
570
571     create table "user" (
572         "id" integer not null primary key autoincrement,
573         "name" text not null,
574         "password" text not null
575     );
576
577     create table "investor" (
578         "id" integer not null references user("id"),
579         "dollars" integer
580     );
581
582 So that investor's PK is just an FK to the user. We can clearly see the class
583 hierarchy here, in which investor is a subclass of user. In DBIx::Class
584 applications, this second strategy looks like:
585
586     my $user_rs = $schema->resultset('User');
587     my $new_user = $user_rs->create(
588         name => $args->{name},
589         password => $args->{password},
590     );
591
592     ...
593
594     my $new_investor = $schema->resultset('Investor')->create(
595         id => $new_user->id,
596         dollars => $args->{dollars},
597     );
598
599 One can cope well with the second strategy, and it seems to be the most popular
600 smart choice.
601
602 =head1 HOW?
603
604 There is a third strategy implemented here. Make the database do more of the
605 work: hide the nasty bits so we don't have to handle them unless we really want
606 to. It'll save us some typing and it'll make for more expressive code. What if
607 we could do this:
608
609     my $new_investor = $schema->resultset('Investor')->create(
610         name => $args->{name},
611         password => $args->{password},
612         dollars => $args->{dollars},
613     );
614
615 And have it Just Work? The user...
616
617     {
618         name => $args->{name},
619         password => $args->{password},
620     }
621
622 should be created behind the scenes, and the use of either user or investor
623 in your code should require no special handling. Deleting and updating
624 $new_investor should also delete or update the user row.
625
626 It does. User and investor are both views, their concrete tables abstracted
627 away behind a set of rules and triggers. You would expect the above DBIC
628 create statement to look like this in SQL:
629
630     INSERT INTO investor ("name","password","dollars") VALUES (...);
631
632 But using MTI, it is really this:
633
634     INSERT INTO _user_table ("username","password") VALUES (...);
635     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
636
637 For deletes, the triggers fire in reverse, to preserve referential integrity
638 (foreign key constraints). For instance:
639
640    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
641    $investor->delete;
642
643 Becomes:
644
645     DELETE FROM _investor_table WHERE ("id" = ?);
646     DELETE FROM _user_table WHERE ("id" = ?);
647
648
649 =head1 METHODS
650
651 =over
652
653 =item new
654
655
656 MTI find the parents, if any, of your resultset class and adds them to the
657 list of parent_sources for the table.
658
659
660 =item add_additional_parents
661
662
663 Continuing with coffee:
664
665     __PACKAGE__->result_source_instance->add_additional_parents(
666         qw/
667             MyApp::Schema::Result::Beverage
668             MyApp::Schema::Result::Liquid
669         /
670     );
671
672 This just lets you manually add additional parents beyond the ones MTI finds.
673
674 =item add_additional_parent
675
676     __PACKAGE__->result_source_instance->add_additional_parent(
677             MyApp::Schema::Result::Beverage
678     );
679
680 You can also add just one.
681
682 =item attach_additional_sources
683
684 MTI takes the parents' sources and relationships, creates a new
685 DBIx::Class::Table object from them, and registers this as a new, raw, source
686 in the schema, e.g.,
687
688     use MyApp::Schema;
689
690     print STDERR map { "$_\n" } MyApp::Schema->sources;
691
692     # Coffee
693     # Beverage
694     # Liquid
695     # Sumatra
696     # Raw::Sumatra
697
698 Raw::Sumatra will be used to generate the view.
699
700 =item view_definition
701
702 This takes the raw table and generates the view (and stored procedures) you will use.
703
704 =back
705
706 =head1 AUTHOR
707
708 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
709
710 =head2 CONTRIBUTORS
711
712 Amiri Barksdale, E<lt>amiri@roosterpirates.comE<gt>
713
714 =head1 COPYRIGHT
715
716 Copyright (c) 2011 the DBIx::Class::ResultSource::MultipleTableInheritance
717 L</AUTHOR> and L</CONTRIBUTORS> as listed above.
718
719 =head1 LICENSE
720
721 This library is free software; you can redistribute it and/or modify
722 it under the same terms as Perl itself.
723
724 =head1 SEE ALSO
725
726 L<DBIx::Class>
727 L<DBIx::Class::ResultSource>
728
729 =cut