1 package DBIx::Class::ResultSource::MultipleTableInheritance;
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;
16 __PACKAGE__->mk_group_accessors(simple => qw(parent_source additional_parents));
20 # On construction, we hook $self->result_class->result_source_instance
21 # if present to get the superclass' source object
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
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.
31 # deploying the postgres rules through SQLT may be a pain though.
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);
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
55 method add_additional_parent ($source) {
56 my ($our_pk, $their_pk) = map {
57 join('|',sort $_->primary_columns)
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
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
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}}},
80 push(@{$self->result_class.'::ISA'}, $source->result_class);
84 method _source_by_name ($name) {
85 my $schema = $self->schema;
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"
94 method schema (@args) {
95 my $ret = $self->next::method(@args);
97 if ($self->parent_source) {
98 my $parent_name = $self->parent_source->name;
99 $self->parent_source($self->_source_by_name($parent_name));
101 $self->additional_parents([
102 map { $self->_source_by_name($_->name) }
103 @{$self->additional_parents||[]}
109 method attach_additional_sources () {
110 my $raw_name = $self->raw_source_name;
111 my $schema = $self->schema;
113 # if the raw source is already present we can assume we're done
114 return if grep { $_ eq $raw_name } $schema->sources;
116 # our parent should've been registered already actually due to DBIC
117 # attaching subclass sources later in load_namespaces
120 if ($self->parent_source) {
121 my $parent_name = $self->parent_source->name;
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"
127 $self->parent_source($parent); # so our parent is the one in this schema
130 # create the raw table source
132 my $table = Table->new({ name => $self->raw_table_name });
134 # we don't need to add the PK cols explicitly if we're the root table
135 # since they'll get added below
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}";
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;
152 foreach my $add (@{$self->additional_parents||[]}) {
153 $table->add_relationship(
154 'parent_'.$add->name, $add->source_name, \%pk_join
156 $self->deploy_depends_on->{$add->result_class} = 1 if $add->isa('DBIx::Class::ResultSource::View');
159 map { ($_ => { %{$self->column_info($_)} }) }
160 grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
163 $table->set_primary_key($self->primary_columns);
165 ## Attempting to re-add sequence here -- AKB
166 #for my $pk ( $self->primary_columns ) {
169 ##use 5.012; use Devel::Dwarn; say Dwarn $schema->source($table->_relationships->{parent}->{class}) if $table->_relationships->{parent}->{class};
170 #$table->columns_info->{$pk}->{sequence} =
171 #$self->set_sequence(
172 #$schema->source( $table->_relationships->{parent}->{class} )->name,
173 #$self->primary_columns )
174 #if $table->columns_info->{$pk}->{originally_defined_in} ne $self->name
175 #&& $table->_relationships->{parent}->{class};
179 # we need to copy our rels to the raw object as well
180 # note that ->add_relationship on a source object doesn't create an
181 # accessor so we can leave that part in the attributes
183 # if the other side is a table then we need to copy any rels it has
184 # back to us, as well, so that they point at the raw table. if the
185 # other side is an MTI view then we need to create the rels to it to
186 # point at -its- raw table; we don't need to worry about backrels because
187 # it's going to run this method too (and its raw source might not exist
188 # yet so we can't, anyway)
190 foreach my $rel ($self->relationships) {
191 my $rel_info = $self->relationship_info($rel);
193 # if we got this from the superclass, -its- raw table will nail this.
194 # if we got it from an additional parent, it's its problem.
195 next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;
197 my $f_source = $schema->source($rel_info->{source});
199 # __PACKAGE__ is correct here because subclasses should be caught
201 my $one_of_us = $f_source->isa(__PACKAGE__);
203 my $f_source_name = $f_source->${\
204 ($one_of_us ? 'raw_source_name' : 'source_name')
207 $table->add_relationship(
208 '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
211 unless ($one_of_us) {
213 # we haven't been registered yet, so reverse_ cries
214 # XXX this is evil and will probably break eventually
215 local @{$schema->source_registrations}
216 {map $self->$_, qw(source_name result_class)}
218 $self->reverse_relationship_info($rel);
220 foreach my $rev_rel (keys %$reverse) {
221 $f_source->add_relationship(
222 '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
228 $schema->register_source($raw_name => $table);
231 method set_primary_key (@args) {
232 if ($self->parent_source) {
233 confess "Can't set primary key on a subclass";
235 return $self->next::method(@args);
238 method set_sequence ($table_name, @pks) {
239 return $table_name . '_' . join('_',@pks) . '_' . 'seq';
242 method raw_source_name () {
243 my $base = $self->source_name;
244 confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
246 return 'Raw::'.$base;
249 method raw_table_name () {
250 return '_'.$self->name;
253 method add_columns (@args) {
254 my $ret = $self->next::method(@args);
255 $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
259 method add_relationship ($name, $f_source, $cond, $attrs) {
261 $name, $f_source, $cond,
262 { originally_defined_in => $self->name, %{$attrs||{}}, }
268 # helper routines, constructed as anon subs so autoclean nukes them
272 *argify = sub (@names) {
276 *qualify_with = sub ($source, @names) {
277 my $name = blessed($source) ? $source->name : $source;
278 map join('.', $name, $_), @names;
281 *body_cols = sub ($source) {
282 my %pk; @pk{$source->primary_columns} = ();
283 map +{ %{$source->column_info($_)}, name => $_ },
284 grep !exists $pk{$_}, $source->columns;
287 *pk_cols = sub ($source) {
288 map +{ %{$source->column_info($_)}, name => $_ },
289 $source->primary_columns;
292 *names_of = sub (@cols) { map $_->{name}, @cols };
294 *function_body = sub {
295 my ($name,$args,$body_parts) = @_;
298 map "_${\$_->{name}} ${\uc($_->{data_type})}",
301 my $body = join("\n", '', map " $_;", @$body_parts);
303 CREATE OR REPLACE FUNCTION [% name %]
305 RETURNS VOID AS $function$
309 $function$ LANGUAGE plpgsql;
312 #*function_body = sub ($name,$args,$body_parts) {
315 #map "_${\$_->{name}} ${\uc($_->{data_type})}",
318 #my $body = join("\n", '', map " $_;", @$body_parts);
320 #CREATE OR REPLACE FUNCTION [% name %]
322 #RETURNS VOID AS $function$
326 #$function$ LANGUAGE plpgsql;
335 *arg_hash = sub ($source) {
336 map +($_ => \(argify $_)), names_of body_cols $source;
339 *rule_body = sub ($on, $to, $oldlist, $newlist) {
340 my $arglist = join(', ',
341 (qualify_with 'OLD', names_of @$oldlist),
342 (qualify_with 'NEW', names_of @$newlist),
344 $to = $to->name if blessed($to);
346 CREATE RULE _[% to %]_[% on %]_rule AS
347 ON [% on | upper %] TO [% to %]
349 SELECT [% to %]_[% on %]([% arglist %])
355 method root_table () {
357 ? $self->parent_source->root_table
358 : $self->schema->source($self->raw_source_name)
361 method view_definition () {
362 my $schema = $self->schema;
363 confess "Can't generate view without connected schema, sorry"
364 unless $schema && $schema->storage;
365 my $sqla = $schema->storage->sql_maker;
366 my $table = $self->schema->source($self->raw_source_name);
367 my $super_view = $self->parent_source;
368 my @all_parents = my @other_parents = @{$self->additional_parents||[]};
369 push(@all_parents, $super_view) if defined($super_view);
370 my @sources = ($table, @all_parents);
371 my @body_cols = map body_cols($_), @sources;
373 # Order body_cols to match the columns order.
374 # Must match or you get typecast errors.
375 my %body_cols = map { $_->{name} => $_ } @body_cols;
377 map { $body_cols{$_} }
378 grep { defined $body_cols{$_} }
380 my @pk_cols = pk_cols $self;
382 # Grab sequence from root table. Only works with one PK named id...
383 # TBD: fix this so it's more flexible.
384 for my $pk_col (@pk_cols) {
385 $self->columns_info->{ $pk_col->{name} }->{sequence} =
386 $self->root_table->name . '_id_seq';
391 my $am_root = !($super_view || @other_parents);
393 my $select = $sqla->select(
396 : ([ # FROM _tbl _tbl
397 { $table->name => $table->name },
401 { $parent->name => $parent->name },
402 # ON _tbl.id = view.id
403 { map +(qualify_with($parent, $_), qualify_with($table, $_)),
409 [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
412 my ($now, @next) = grep defined, $super_view, $table, @other_parents;
416 # NOTE: this assumes a single PK col called id with a sequence somewhere
417 # but nothing else -should- so fixing this should make everything work
420 $self->name.'_insert',
423 $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
428 $sqla->insert( # INSERT INTO parent (id, ...)
429 # VALUES (currval('_root_tbl_id_seq'), ...)
433 id => \"currval('${\$self->root_table->name}_id_seq')",
439 # note - similar to arg_hash but not quite enough to share code sanely
440 my $pk_where = { # id = _id AND id2 = _id2 ...
441 map +($_ => \"= ${\argify $_}"), names_of @pk_cols
448 $self->name.'_update',
449 [ @pk_cols, @body_cols ],
451 $_->name, # UPDATE foo
452 { arg_hash $_ }, # SET a = _a
461 $self->name.'_delete',
463 [ map $sqla->delete($_->name, $pk_where), @sources ];
466 (rule_body insert => $self, [], \@body_cols),
467 (rule_body update => $self, \@pk_cols, \@body_cols),
468 (rule_body delete => $self, \@pk_cols, []),
470 return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
479 DBIx::Class::ResultSource::MultipleTableInheritance
480 Use multiple tables to define your classes
484 This only works with PostgreSQL for the moment.
489 package Cafe::Result::Coffee;
493 use parent 'DBIx::Class::Core';
494 use aliased 'DBIx::Class::ResultSource::MultipleTableInheritance'
497 __PACKAGE__->table_class(MTI);
498 __PACKAGE__->table('coffee');
499 __PACKAGE__->add_columns(
500 "id", { data_type => "integer" },
503 default_value => "good" },
506 __PACKAGE__->set_primary_key("id");
512 package Cafe::Result::Sumatra;
514 use parent 'Cafe::Result::Coffee';
516 __PACKAGE__->table('sumatra');
518 __PACKAGE__->add_columns( "aroma",
519 { data_type => "text" }
527 my $schema = Cafe->connect($dsn,$user,$pass);
529 my $cup = $schema->resultset('Sumatra');
531 print STDERR Dwarn $cup->result_source->columns;
538 Inherit from this package and you can make a resultset class from a view, but
539 that's more than a little bit misleading: the result is B<transparently
542 This is accomplished through the use of stored procedures that map changes
543 written to the view to changes to the underlying concrete tables.
547 In many applications, many classes are subclasses of others. Let's say you
550 # Conceptual domain model
565 That's redundant. Hold on a sec...
573 class Investor extends User {
577 Good idea, but how to put this into code?
579 One far-too common and absolutely horrendous solution is to have a "checkbox"
580 in your database: a nullable "investor" column, which entails a nullable
581 "dollars" column, in the user table.
583 create table "user" (
584 "id" integer not null primary key autoincrement,
585 "name" text not null,
586 "password" text not null,
587 "investor" tinyint(1),
591 Let's not discuss that further.
593 A second, better, solution is to break out the two tables into user and
596 create table "user" (
597 "id" integer not null primary key autoincrement,
598 "name" text not null,
599 "password" text not null
602 create table "investor" (
603 "id" integer not null references user("id"),
607 So that investor's PK is just an FK to the user. We can clearly see the class
608 hierarchy here, in which investor is a subclass of user. In DBIx::Class
609 applications, this second strategy looks like:
611 my $user_rs = $schema->resultset('User');
612 my $new_user = $user_rs->create(
613 name => $args->{name},
614 password => $args->{password},
619 my $new_investor = $schema->resultset('Investor')->create(
621 dollars => $args->{dollars},
624 One can cope well with the second strategy, and it seems to be the most popular
629 There is a third strategy implemented here. Make the database do more of the
630 work: hide the nasty bits so we don't have to handle them unless we really want
631 to. It'll save us some typing and it'll make for more expressive code. What if
634 my $new_investor = $schema->resultset('Investor')->create(
635 name => $args->{name},
636 password => $args->{password},
637 dollars => $args->{dollars},
640 And have it Just Work? The user...
643 name => $args->{name},
644 password => $args->{password},
647 should be created behind the scenes, and the use of either user or investor
648 in your code should require no special handling. Deleting and updating
649 $new_investor should also delete or update the user row.
651 It does. User and investor are both views, their concrete tables abstracted
652 away behind a set of rules and triggers. You would expect the above DBIC
653 create statement to look like this in SQL:
655 INSERT INTO investor ("name","password","dollars") VALUES (...);
657 But using MTI, it is really this:
659 INSERT INTO _user_table ("username","password") VALUES (...);
660 INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
662 For deletes, the triggers fire in reverse, to preserve referential integrity
663 (foreign key constraints). For instance:
665 my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
670 DELETE FROM _investor_table WHERE ("id" = ?);
671 DELETE FROM _user_table WHERE ("id" = ?);
681 MTI find the parents, if any, of your resultset class and adds them to the
682 list of parent_sources for the table.
685 =item add_additional_parents
688 Continuing with coffee:
690 __PACKAGE__->result_source_instance->add_additional_parents(
692 MyApp::Schema::Result::Beverage
693 MyApp::Schema::Result::Liquid
697 This just lets you manually add additional parents beyond the ones MTI finds.
699 =item add_additional_parent
701 __PACKAGE__->result_source_instance->add_additional_parent(
702 MyApp::Schema::Result::Beverage
705 You can also add just one.
707 =item attach_additional_sources
709 MTI takes the parents' sources and relationships, creates a new
710 DBIx::Class::Table object from them, and registers this as a new, raw, source
715 print STDERR map { "$_\n" } MyApp::Schema->sources;
723 Raw::Sumatra will be used to generate the view.
725 =item view_definition
727 This takes the raw table and generates the view (and stored procedures) you will use.
733 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
737 Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
741 Copyright (c) 2010 the DBIx::Class::ResultSource::MultipleTableInheritance
742 L</AUTHOR> and L</CONTRIBUTORS> as listed above.
746 This library is free software; you can redistribute it and/or modify
747 it under the same terms as Perl itself.
752 L<DBIx::Class::ResultSource>