Extend Cafe tests.
[dbsrgits/DBIx-Class-ResultSource-MultipleTableInheritance.git] / lib / DBIx / Class / ResultSource / MultipleTableInheritance.pm
CommitLineData
876f6525 1package DBIx::Class::ResultSource::MultipleTableInheritance;
2
3use strict;
4use warnings;
5use parent qw(DBIx::Class::ResultSource::View);
876f6525 6use Method::Signatures::Simple;
7use Carp::Clan qw/^DBIx::Class/;
ca79850d 8use aliased 'DBIx::Class::ResultSource::Table';
7abe3af2 9use aliased 'DBIx::Class::ResultClass::HashRefInflator';
05fd2477 10use String::TT qw(strip tt);
92ebfc06 11use Scalar::Util qw(blessed);
ca79850d 12use namespace::autoclean;
70d56286 13
146ec120 14our $VERSION = 0.01;
70d56286 15
803ffff2 16__PACKAGE__->mk_group_accessors(simple => qw(parent_source additional_parents));
876f6525 17
e7189506 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
876f6525 33method 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')) {
7abe3af2 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 }
876f6525 42 }
43 return $new;
44}
45
4e4f71e3 46method 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
803ffff2 55method 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 }
a010ebf9 79 { no strict 'refs';
80 push(@{$self->result_class.'::ISA'}, $source->result_class);
81 }
803ffff2 82}
83
8b229aa6 84method _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
7abe3af2 94method schema (@args) {
95 my $ret = $self->next::method(@args);
96 if (@args) {
c73d582b 97 if ($self->parent_source) {
c73d582b 98 my $parent_name = $self->parent_source->name;
8b229aa6 99 $self->parent_source($self->_source_by_name($parent_name));
c73d582b 100 }
8b229aa6 101 $self->additional_parents([
102 map { $self->_source_by_name($_->name) }
103 @{$self->additional_parents||[]}
104 ]);
7abe3af2 105 }
106 return $ret;
107}
108
c73d582b 109method attach_additional_sources () {
4d88a8d7 110 my $raw_name = $self->raw_source_name;
ca79850d 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;
4d88a8d7 115
ca79850d 116 # our parent should've been registered already actually due to DBIC
117 # attaching subclass sources later in load_namespaces
4d88a8d7 118
ca79850d 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;
05fd2477 127 $self->parent_source($parent); # so our parent is the one in this schema
ca79850d 128 }
4d88a8d7 129
130 # create the raw table source
131
132 my $table = Table->new({ name => $self->raw_table_name });
133
ca79850d 134 # we don't need to add the PK cols explicitly if we're the root table
4d88a8d7 135 # since they'll get added below
136
803ffff2 137 my %pk_join;
138
ca79850d 139 if ($parent) {
ca79850d 140 foreach my $pri ($self->primary_columns) {
141 my %info = %{$self->column_info($pri)};
142 delete @info{qw(is_auto_increment sequence auto_nextval)};
7abe3af2 143 $table->add_column($pri => \%info);
803ffff2 144 $pk_join{"foreign.${pri}"} = "self.${pri}";
ca79850d 145 }
4d88a8d7 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
803ffff2 148 $table->add_relationship('parent', $parent->raw_source_name, \%pk_join);
3c9baea8 149 $self->deploy_depends_on->{$parent->source_name} = 1;
803ffff2 150 }
151
152 foreach my $add (@{$self->additional_parents||[]}) {
153 $table->add_relationship(
154 'parent_'.$add->name, $add->source_name, \%pk_join
155 );
3c9baea8 156 $self->deploy_depends_on->{$add->source_name} = 1;
ca79850d 157 }
4d88a8d7 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 );
ca79850d 166 $table->set_primary_key($self->primary_columns);
490d5481 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
803ffff2 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
490d5481 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
ca79850d 217 $schema->register_source($raw_name => $table);
218}
219
220method 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);
876f6525 225}
226
4d88a8d7 227method raw_source_name () {
876f6525 228 my $base = $self->source_name;
05fd2477 229 confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
876f6525 230 unless $base;
231 return 'Raw::'.$base;
232}
70d56286 233
4d88a8d7 234method raw_table_name () {
235 return '_'.$self->name;
236}
237
876f6525 238method add_columns (@args) {
239 my $ret = $self->next::method(@args);
240 $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
241 return $ret;
70d56286 242}
243
803ffff2 244method 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
487f4489 251BEGIN {
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) {
92ebfc06 262 my $name = blessed($source) ? $source->name : $source;
263 map join('.', $name, $_), @names;
487f4489 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
92ebfc06 277 *names_of = sub (@cols) { map $_->{name}, @cols };
487f4489 278
f8864134 279 *functionbody = sub ($name, $args, $body_parts) {
05fd2477 280 my $arglist = join(
281 ', ',
388d83fc 282 map "_${\$_->{name}} ${\uc($_->{data_type})}",
05fd2477 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 };
487f4489 295 };
487f4489 296}
297
05fd2477 298BEGIN {
299
300 use signatures;
301
302 *arg_hash = sub ($source) {
303 map +($_ => \(argify $_)), names_of body_cols $source;
304 };
92ebfc06 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 (
3c259cfb 316 SELECT [% to %]_[% on %]([% arglist %])
92ebfc06 317 );
318 };
319 };
05fd2477 320}
321
322method root_table () {
323 $self->parent_source
324 ? $self->parent_source->root_table
325 : $self->schema->source($self->raw_source_name)
326}
327
487f4489 328method 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;
2816c8ed 333 my $table = $self->schema->source($self->raw_source_name);
487f4489 334 my $super_view = $self->parent_source;
2816c8ed 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);
487f4489 338 my @body_cols = map body_cols($_), @sources;
339 my @pk_cols = pk_cols $self;
92ebfc06 340
341 # SELECT statement
342
2816c8ed 343 my $am_root = !($super_view || @other_parents);
344
487f4489 345 my $select = $sqla->select(
2816c8ed 346 ($am_root
347 ? ($table->name)
348 : ([ # FROM _tbl _tbl
487f4489 349 { $table->name => $table->name },
2816c8ed 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
487f4489 359 ])
2816c8ed 360 ),
487f4489 361 [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
05fd2477 362 ).';';
92ebfc06 363
2816c8ed 364 my ($now, @next) = grep defined, $super_view, $table, @other_parents;
92ebfc06 365
366 # INSERT function
367
05fd2477 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 =
f8864134 371 functionbody
05fd2477 372 $self->name.'_insert',
373 \@body_cols,
374 [
2816c8ed 375 $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
05fd2477 376 $now->name,
377 { arg_hash $now },
378 ),
2816c8ed 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)
05fd2477 389 ];
92ebfc06 390
05fd2477 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 };
92ebfc06 395
396 # UPDATE function
397
05fd2477 398 my $update_func =
f8864134 399 functionbody
05fd2477 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 ];
92ebfc06 408
409 # DELETE function
410
05fd2477 411 my $delete_func =
f8864134 412 functionbody
05fd2477 413 $self->name.'_delete',
414 [ @pk_cols ],
415 [ map $sqla->delete($_->name, $pk_where), @sources ];
92ebfc06 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);
487f4489 423}
424
70d56286 4251;
146ec120 426
427__END__
f5c54951 428
146ec120 429=head1 NAME
430
f5c54951 431DBIx::Class::ResultSource::MultipleTableInheritance
432Use multiple tables to define your classes
433
434=head1 NOTICE
435
436This only works with PostgreSQL for the moment.
146ec120 437
438=head1 SYNOPSIS
439
146ec120 440 {
f8864134 441 package Cafe::Result::Coffee;
146ec120 442
f8864134 443 use strict;
444 use warnings;
445 use parent 'DBIx::Class::Core';
446 use aliased 'DBIx::Class::ResultSource::MultipleTableInheritance'
447 => 'MTI';
448
449 __PACKAGE__->table_class(MTI);
146ec120 450 __PACKAGE__->table('coffee');
451 __PACKAGE__->add_columns(
f8864134 452 "id", { data_type => "integer" },
453 "flavor", {
454 data_type => "text",
455 default_value => "good" },
146ec120 456 );
457
458 __PACKAGE__->set_primary_key("id");
459
460 1;
461 }
462
463 {
f8864134 464 package Cafe::Result::Sumatra;
146ec120 465
f8864134 466 use parent 'Cafe::Result::Coffee';
146ec120 467
468 __PACKAGE__->table('sumatra');
469
f8864134 470 __PACKAGE__->add_columns( "aroma",
471 { data_type => "text" }
146ec120 472 );
473
474 1;
475 }
476
477 ...
478
f8864134 479 my $schema = Cafe->connect($dsn,$user,$pass);
146ec120 480
f8864134 481 my $cup = $schema->resultset('Sumatra');
146ec120 482
f8864134 483 print STDERR Dwarn $cup->result_source->columns;
146ec120 484
f8864134 485 "id"
486 "flavor"
487 "aroma"
488 ..
146ec120 489
f5c54951 490Inherit from this package and you can make a resultset class from a view, but
491that's more than a little bit misleading: the result is B<transparently
492writable>.
146ec120 493
f5c54951 494This is accomplished through the use of stored procedures that map changes
495written to the view to changes to the underlying concrete tables.
146ec120 496
497=head1 WHY?
498
f5c54951 499In many applications, many classes are subclasses of others. Let's say you
500have this schema:
146ec120 501
502 # Conceptual domain model
503
504 class User {
f5c54951 505 has id,
506 has name,
507 has password
146ec120 508 }
509
510 class Investor {
511 has id,
512 has name,
513 has password,
514 has dollars
515 }
516
517That's redundant. Hold on a sec...
518
519 class User {
f5c54951 520 has id,
521 has name,
522 has password
146ec120 523 }
524
e7189506 525 class Investor extends User {
146ec120 526 has dollars
527 }
528
529Good idea, but how to put this into code?
530
f5c54951 531One far-too common and absolutely horrendous solution is to have a "checkbox"
532in your database: a nullable "investor" column, which entails a nullable
533"dollars" column, in the user table.
146ec120 534
535 create table "user" (
536 "id" integer not null primary key autoincrement,
537 "name" text not null,
538 "password" text not null,
539 "investor" tinyint(1),
540 "dollars" integer
541 );
542
543Let's not discuss that further.
544
f5c54951 545A second, better, solution is to break out the two tables into user and
546investor:
146ec120 547
548 create table "user" (
549 "id" integer not null primary key autoincrement,
550 "name" text not null,
551 "password" text not null
552 );
553
554 create table "investor" (
555 "id" integer not null references user("id"),
556 "dollars" integer
557 );
558
f5c54951 559So that investor's PK is just an FK to the user. We can clearly see the class
560hierarchy here, in which investor is a subclass of user. In DBIx::Class
561applications, this second strategy looks like:
146ec120 562
563 my $user_rs = $schema->resultset('User');
564 my $new_user = $user_rs->create(
565 name => $args->{name},
566 password => $args->{password},
567 );
568
569 ...
570
571 my $new_investor = $schema->resultset('Investor')->create(
572 id => $new_user->id,
573 dollars => $args->{dollars},
574 );
575
f5c54951 576One can cope well with the second strategy, and it seems to be the most popular
577smart choice.
e7189506 578
146ec120 579=head1 HOW?
580
f5c54951 581There is a third strategy implemented here. Make the database do more of the
582work: hide the nasty bits so we don't have to handle them unless we really want
583to. It'll save us some typing and it'll make for more expressive code. What if
584we could do this:
146ec120 585
586 my $new_investor = $schema->resultset('Investor')->create(
587 name => $args->{name},
588 password => $args->{password},
589 dollars => $args->{dollars},
590 );
591
e7189506 592And have it Just Work? The user...
593
594 {
595 name => $args->{name},
596 password => $args->{password},
597 }
598
f5c54951 599should be created behind the scenes, and the use of either user or investor
600in your code should require no special handling. Deleting and updating
601$new_investor should also delete or update the user row.
146ec120 602
f5c54951 603It does. User and investor are both views, their concrete tables abstracted
604away behind a set of rules and triggers. You would expect the above DBIC
605create statement to look like this in SQL:
146ec120 606
607 INSERT INTO investor ("name","password","dollars") VALUES (...);
608
609But using MTI, it is really this:
610
611 INSERT INTO _user_table ("username","password") VALUES (...);
612 INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
613
f5c54951 614For deletes, the triggers fire in reverse, to preserve referential integrity
615(foreign key constraints). For instance:
146ec120 616
617 my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
618 $investor->delete;
619
620Becomes:
621
622 DELETE FROM _investor_table WHERE ("id" = ?);
623 DELETE FROM _user_table WHERE ("id" = ?);
624
625
e7189506 626=head1 METHODS
627
628=over
629
630=item new
631
632
f5c54951 633MTI find the parents, if any, of your resultset class and adds them to the
634list of parent_sources for the table.
e7189506 635
636
637=item add_additional_parents
638
639
640Continuing with coffee:
641
642 __PACKAGE__->result_source_instance->add_additional_parents(
643 qw/
644 MyApp::Schema::Result::Beverage
645 MyApp::Schema::Result::Liquid
646 /
647 );
648
649This just lets you manually add additional parents beyond the ones MTI finds.
650
651=item add_additional_parent
652
653 __PACKAGE__->result_source_instance->add_additional_parent(
654 MyApp::Schema::Result::Beverage
655 );
656
657You can also add just one.
658
659=item attach_additional_sources
660
f5c54951 661MTI takes the parents' sources and relationships, creates a new
662DBIx::Class::Table object from them, and registers this as a new, raw, source
663in the schema, e.g.,
e7189506 664
665 use MyApp::Schema;
666
667 print STDERR map { "$_\n" } MyApp::Schema->sources;
668
669 # Coffee
670 # Beverage
671 # Liquid
672 # Sumatra
673 # Raw::Sumatra
146ec120 674
e7189506 675Raw::Sumatra will be used to generate the view.
146ec120 676
e7189506 677=item view_definition
146ec120 678
e7189506 679This takes the raw table and generates the view (and stored procedures) you will use.
146ec120 680
e7189506 681=back
146ec120 682
683=head1 AUTHOR
684
685Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
686
687=head2 CONTRIBUTORS
688
f5c54951 689Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
690
691=head1 COPYRIGHT
692
693Copyright (c) 2010 the DBIx::Class::ResultSource::MultipleTableInheritance
694L</AUTHOR> and L</CONTRIBUTORS> as listed above.
146ec120 695
696=head1 LICENSE
697
698This library is free software; you can redistribute it and/or modify
699it under the same terms as Perl itself.
700
701=head1 SEE ALSO
702
703L<DBIx::Class>
704L<DBIx::Class::ResultSource>
705
706=cut