Add some subroutine docs. Must write another test so that I can understand all ins...
[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->depends_on->{$parent->source_name} = 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->depends_on->{$add->source_name} = 1;
157   }
158
159   # add every column that's actually a concrete part of us
160
161   $table->add_columns(
162     map { ($_ => { %{$self->column_info($_)} }) }
163       grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
164         $self->columns
165   );
166   $table->set_primary_key($self->primary_columns);
167
168   # we need to copy our rels to the raw object as well
169   # note that ->add_relationship on a source object doesn't create an
170   # accessor so we can leave that part in the attributes
171
172   # if the other side is a table then we need to copy any rels it has
173   # back to us, as well, so that they point at the raw table. if the
174   # other side is an MTI view then we need to create the rels to it to
175   # point at -its- raw table; we don't need to worry about backrels because
176   # it's going to run this method too (and its raw source might not exist
177   # yet so we can't, anyway)
178
179   foreach my $rel ($self->relationships) {
180     my $rel_info = $self->relationship_info($rel);
181
182     # if we got this from the superclass, -its- raw table will nail this.
183     # if we got it from an additional parent, it's its problem.
184     next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;
185
186     my $f_source = $schema->source($rel_info->{source});
187
188     # __PACKAGE__ is correct here because subclasses should be caught
189
190     my $one_of_us = $f_source->isa(__PACKAGE__);
191
192     my $f_source_name = $f_source->${\
193                         ($one_of_us ? 'raw_source_name' : 'source_name')
194                       };
195     
196     $table->add_relationship(
197       '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
198     );
199
200     unless ($one_of_us) {
201       my $reverse = do {
202         # we haven't been registered yet, so reverse_ cries
203         # XXX this is evil and will probably break eventually
204         local @{$schema->source_registrations}
205                {map $self->$_, qw(source_name result_class)}
206           = ($self, $self);
207         $self->reverse_relationship_info($rel);
208       };
209       foreach my $rev_rel (keys %$reverse) {
210         $f_source->add_relationship(
211           '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
212         );
213       }
214     }
215   }
216
217   $schema->register_source($raw_name => $table);
218 }
219
220 method set_primary_key (@args) {
221   if ($self->parent_source) {
222     confess "Can't set primary key on a subclass";
223   }
224   return $self->next::method(@args);
225 }
226
227 method raw_source_name () {
228   my $base = $self->source_name;
229   confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
230     unless $base;
231   return 'Raw::'.$base;
232 }
233
234 method raw_table_name () {
235   return '_'.$self->name;
236 }
237
238 method add_columns (@args) {
239   my $ret = $self->next::method(@args);
240   $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
241   return $ret;
242 }
243
244 method add_relationship ($name, $f_source, $cond, $attrs) {
245   $self->next::method(
246     $name, $f_source, $cond,
247     { originally_defined_in => $self->name, %{$attrs||{}}, }
248   );
249 }
250
251 BEGIN {
252
253   # helper routines, constructed as anon subs so autoclean nukes them
254
255   use signatures;
256
257   *argify = sub (@names) {
258     map '_'.$_, @names;
259   };
260
261   *qualify_with = sub ($source, @names) {
262     my $name = blessed($source) ? $source->name : $source;
263     map join('.', $name, $_), @names;
264   };
265
266   *body_cols = sub ($source) {
267     my %pk; @pk{$source->primary_columns} = ();
268     map +{ %{$source->column_info($_)}, name => $_ },
269       grep !exists $pk{$_}, $source->columns;
270   };
271
272   *pk_cols = sub ($source) {
273     map +{ %{$source->column_info($_)}, name => $_ },
274       $source->primary_columns;
275   };
276
277   *names_of = sub (@cols) { map $_->{name}, @cols };
278
279   *function_body = sub ($name, $args, $body_parts) {
280     my $arglist = join(
281       ', ',
282         map "_${\$_->{name}} ${\uc($_->{data_type})}",
283           @$args
284     );
285     my $body = join("\n", '', map "          $_;", @$body_parts);
286     return strip tt q{
287       CREATE OR REPLACE FUNCTION [% name %]
288         ([% arglist %])
289         RETURNS VOID AS $function$
290         BEGIN
291           [%- body %]
292         END;
293       $function$ LANGUAGE plpgsql;
294     };
295   };
296 }
297
298 BEGIN {
299
300   use signatures;
301
302   *arg_hash = sub ($source) {
303     map +($_ => \(argify $_)), names_of body_cols $source;
304   };
305
306   *rule_body = sub ($on, $to, $oldlist, $newlist) {
307     my $arglist = join(', ',
308       (qualify_with 'OLD', names_of @$oldlist),
309       (qualify_with 'NEW', names_of @$newlist),
310     );
311     $to = $to->name if blessed($to);
312     return strip tt q{
313       CREATE RULE _[% to %]_[% on %]_rule AS
314         ON [% on | upper %] TO [% to %]
315         DO INSTEAD (
316           SELECT [% to %]_[% on %]([% arglist %])
317         );
318     };
319   };
320 }
321
322 method root_table () {
323   $self->parent_source
324     ? $self->parent_source->root_table
325     : $self->schema->source($self->raw_source_name)
326 }
327
328 method view_definition () {
329   my $schema = $self->schema;
330   confess "Can't generate view without connected schema, sorry"
331     unless $schema && $schema->storage;
332   my $sqla = $schema->storage->sql_maker;
333   my $table = $self->schema->source($self->raw_source_name);
334   my $super_view = $self->parent_source;
335   my @all_parents = my @other_parents = @{$self->additional_parents||[]};
336   push(@all_parents, $super_view) if defined($super_view);
337   my @sources = ($table, @all_parents);
338   my @body_cols = map body_cols($_), @sources;
339   my @pk_cols = pk_cols $self;
340
341   # SELECT statement
342
343   my $am_root = !($super_view || @other_parents);
344
345   my $select = $sqla->select(
346     ($am_root
347       ? ($table->name)
348       : ([   # FROM _tbl _tbl
349            { $table->name => $table->name },
350            map {
351              my $parent = $_;
352              [ # JOIN view view
353                { $parent->name => $parent->name },
354                # ON _tbl.id = view.id
355                { map +(qualify_with($parent, $_), qualify_with($table, $_)),
356                    names_of @pk_cols }
357              ]
358            } @all_parents
359          ])
360       ),
361     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
362   ).';';
363
364   my ($now, @next) = grep defined, $super_view, $table, @other_parents;
365
366   # INSERT function
367
368   # NOTE: this assumes a single PK col called id with a sequence somewhere
369   # but nothing else -should- so fixing this should make everything work
370   my $insert_func =
371     function_body
372       $self->name.'_insert',
373       \@body_cols,
374       [
375         $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
376           $now->name,
377           { arg_hash $now },
378         ),
379         (map {
380           $sqla->insert( # INSERT INTO parent (id, ...)
381                          #   VALUES (currval('_root_tbl_id_seq'), ...)
382             $_->name,
383             {
384               (arg_hash $_),
385               id => \"currval('${\$self->root_table->name}_id_seq')",
386             }
387           )
388         } @next)
389       ];
390
391   # note - similar to arg_hash but not quite enough to share code sanely
392   my $pk_where = { # id = _id AND id2 = _id2 ...
393     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
394   };
395
396   # UPDATE function
397
398   my $update_func =
399     function_body
400       $self->name.'_update',
401       [ @pk_cols, @body_cols ],
402       [ map $sqla->update(
403           $_->name, # UPDATE foo
404           { arg_hash $_ }, # SET a = _a
405           $pk_where,
406         ), @sources
407       ];
408
409   # DELETE function
410
411   my $delete_func =
412     function_body
413       $self->name.'_delete',
414       [ @pk_cols ],
415       [ map $sqla->delete($_->name, $pk_where), @sources ];
416
417   my @rules = (
418     (rule_body insert => $self, [], \@body_cols),
419     (rule_body update => $self, \@pk_cols, \@body_cols),
420     (rule_body delete => $self, \@pk_cols, []),
421   );
422   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
423 }
424
425 1;
426
427 __END__
428 =head1 NAME
429
430 DBIx::Class::ResultSource::MultipleTableInheritance -- Use multiple tables to define your classes 
431
432 =head1 SYNOPSIS
433
434     {
435         package MyApp::Schema::Result::Coffee;
436
437         __PACKAGE__->table_class('DBIx::Class::ResultSource::MultipleTableInheritance');
438         __PACKAGE__->table('coffee');
439         __PACKAGE__->add_columns(
440           "id",
441           {
442             data_type => "integer",
443             default_value => "nextval('coffee_seq'::regclass)",
444             is_auto_increment => 1,
445             is_foreign_key => 1,
446             is_nullable => 0,
447             size => 4,
448           },
449           "flavor",
450           {
451             data_type => "text",
452             default_value => "good",
453           },
454         );
455
456         __PACKAGE__->set_primary_key("id");
457
458         1;
459     }
460
461     {
462         package MyApp::Schema::Result::Sumatra;
463
464         use parent 'Coffee';
465
466         __PACKAGE__->table('sumatra');
467
468         __PACKAGE__->add_columns(
469           "aroma",
470           {
471             data_type => "text",
472             default_value => undef,
473             is_nullable => 0,
474           },
475         );
476
477         1;
478     }
479     
480     ...
481
482     my $schema = MyApp::Schema->connect($dsn);
483
484     my $cup = $schema->resultset('Sumatra')->new;
485
486     print STDERR Dumper $cup->columns;
487
488         $VAR1 = 'id';
489         $VAR2 = 'flavor';
490         $VAR3 = 'aroma';
491
492
493 Inherit from this package and you can make a resultset class from a view, but that's more than a little bit misleading: the result is B<transparently writable>.
494
495 This is accomplished through the use of stored procedures that map changes written to the view to changes to the underlying concrete tables.
496
497
498 =head1 WHY?
499
500 In many applications, many classes are subclasses of others. Let's say you have this schema:
501
502     # Conceptual domain model
503     
504     class User {
505             has id,
506             has name,
507             has password
508     }
509
510     class Investor {
511         has id,
512         has name,
513         has password,
514         has dollars
515     }
516
517 That's redundant. Hold on a sec...
518
519     class User {
520             has id,
521             has name,
522             has password
523     }
524
525     class Investor extends User {
526         has dollars
527     }
528
529 Good idea, but how to put this into code?
530
531 One far-too common and absolutely horrendous solution is to have a "checkbox" in your database: a nullable "investor" column, which entails a nullable "dollars" column, in the user table.
532
533     create table "user" (
534         "id" integer not null primary key autoincrement,
535         "name" text not null,
536         "password" text not null,
537         "investor" tinyint(1),
538         "dollars" integer
539     );
540
541 Let's not discuss that further.
542
543 A second, better, solution is to break out the two tables into user and investor:
544
545     create table "user" (
546         "id" integer not null primary key autoincrement,
547         "name" text not null,
548         "password" text not null
549     );
550         
551     create table "investor" (
552         "id" integer not null references user("id"),
553         "dollars" integer
554     );
555
556 So that investor's PK is just an FK to the user. We can clearly see the class hierarchy here, in which investor is a subclass of user. In DBIx::Class applications, this second strategy looks like:
557     
558     my $user_rs = $schema->resultset('User');
559     my $new_user = $user_rs->create(
560         name => $args->{name},
561         password => $args->{password},
562     );
563
564     ...
565
566     my $new_investor = $schema->resultset('Investor')->create(
567         id => $new_user->id,
568         dollars => $args->{dollars},
569     );
570
571 One can cope well with the second strategy, and it seems to be the most popular smart choice.
572
573
574 =head1 HOW?
575
576 There is a third strategy implemented here. Make the database do more of the work: hide the nasty bits so we don't have to handle them unless we really want to. It'll save us some typing and it'll make for more expressive code. What if we could do this:
577
578     my $new_investor = $schema->resultset('Investor')->create(
579         name => $args->{name},
580         password => $args->{password},
581         dollars => $args->{dollars},
582     );
583     
584 And have it Just Work? The user...
585
586     {
587         name => $args->{name},
588         password => $args->{password},
589     }
590
591 should be created behind the scenes, and the use of either user or investor in your code should require no special handling. Deleting and updating $new_investor should also delete or update the user row.
592
593 It does. User and investor are both views, their concrete tables abstracted away behind a set of rules and triggers. You would expect the above DBIC create statement to look like this in SQL:
594
595     INSERT INTO investor ("name","password","dollars") VALUES (...);
596
597 But using MTI, it is really this:
598
599     INSERT INTO _user_table ("username","password") VALUES (...);
600     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
601
602 For deletes, the triggers fire in reverse, to preserve referential integrity (foreign key constraints). For instance:
603
604    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
605    $investor->delete;
606
607 Becomes:
608
609     DELETE FROM _investor_table WHERE ("id" = ?);
610     DELETE FROM _user_table WHERE ("id" = ?);
611
612
613 =head1 METHODS
614
615 =over
616
617 =item new
618
619
620 MTI find the parents, if any, of your resultset class and adds them to the list of parent_sources for the table.
621
622
623 =item add_additional_parents
624
625
626 Continuing with coffee:
627
628     __PACKAGE__->result_source_instance->add_additional_parents(
629         qw/
630             MyApp::Schema::Result::Beverage
631             MyApp::Schema::Result::Liquid
632         /
633     );
634
635 This just lets you manually add additional parents beyond the ones MTI finds.
636
637 =item add_additional_parent
638
639     __PACKAGE__->result_source_instance->add_additional_parent(
640             MyApp::Schema::Result::Beverage
641     );
642
643 You can also add just one.
644
645 =item attach_additional_sources
646
647 MTI takes the parents' sources and relationships, creates new DBIx::Class:Table object from them, and registers this as a new, raw, source in the schema, e.g.,
648
649     use MyApp::Schema;
650
651     print STDERR map { "$_\n" } MyApp::Schema->sources;
652
653     # Coffee 
654     # Beverage
655     # Liquid
656     # Sumatra
657     # Raw::Sumatra
658
659 Raw::Sumatra will be used to generate the view.
660
661 =item view_definition
662
663 This takes the raw table and generates the view (and stored procedures) you will use.
664
665 =back
666
667 =head1 AUTHOR
668
669 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
670
671 =head2 CONTRIBUTORS
672
673 Docs: Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
674
675 =head1 LICENSE
676
677 This library is free software; you can redistribute it and/or modify
678 it under the same terms as Perl itself.
679
680 =head1 SEE ALSO
681
682 L<DBIx::Class>
683 L<DBIx::Class::ResultSource>
684
685 =cut