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->depends_on->{$parent->source_name} = 1;
152 foreach my $add (@{$self->additional_parents||[]}) {
153 $table->add_relationship(
154 'parent_'.$add->name, $add->source_name, \%pk_join
156 $self->depends_on->{$add->source_name} = 1;
159 # add every column that's actually a concrete part of us
162 map { ($_ => { %{$self->column_info($_)} }) }
163 grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
166 $table->set_primary_key($self->primary_columns);
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
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)
179 foreach my $rel ($self->relationships) {
180 my $rel_info = $self->relationship_info($rel);
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;
186 my $f_source = $schema->source($rel_info->{source});
188 # __PACKAGE__ is correct here because subclasses should be caught
190 my $one_of_us = $f_source->isa(__PACKAGE__);
192 my $f_source_name = $f_source->${\
193 ($one_of_us ? 'raw_source_name' : 'source_name')
196 $table->add_relationship(
197 '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
200 unless ($one_of_us) {
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)}
207 $self->reverse_relationship_info($rel);
209 foreach my $rev_rel (keys %$reverse) {
210 $f_source->add_relationship(
211 '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
217 $schema->register_source($raw_name => $table);
220 method set_primary_key (@args) {
221 if ($self->parent_source) {
222 confess "Can't set primary key on a subclass";
224 return $self->next::method(@args);
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"
231 return 'Raw::'.$base;
234 method raw_table_name () {
235 return '_'.$self->name;
238 method add_columns (@args) {
239 my $ret = $self->next::method(@args);
240 $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
244 method add_relationship ($name, $f_source, $cond, $attrs) {
246 $name, $f_source, $cond,
247 { originally_defined_in => $self->name, %{$attrs||{}}, }
253 # helper routines, constructed as anon subs so autoclean nukes them
257 *argify = sub (@names) {
261 *qualify_with = sub ($source, @names) {
262 my $name = blessed($source) ? $source->name : $source;
263 map join('.', $name, $_), @names;
266 *body_cols = sub ($source) {
267 my %pk; @pk{$source->primary_columns} = ();
268 map +{ %{$source->column_info($_)}, name => $_ },
269 grep !exists $pk{$_}, $source->columns;
272 *pk_cols = sub ($source) {
273 map +{ %{$source->column_info($_)}, name => $_ },
274 $source->primary_columns;
277 *names_of = sub (@cols) { map $_->{name}, @cols };
279 *function_body = sub ($name, $args, $body_parts) {
282 map "_${\$_->{name}} ${\uc($_->{data_type})}",
285 my $body = join("\n", '', map " $_;", @$body_parts);
287 CREATE OR REPLACE FUNCTION [% name %]
289 RETURNS VOID AS $function$
293 $function$ LANGUAGE plpgsql;
302 *arg_hash = sub ($source) {
303 map +($_ => \(argify $_)), names_of body_cols $source;
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),
311 $to = $to->name if blessed($to);
313 CREATE RULE _[% to %]_[% on %]_rule AS
314 ON [% on | upper %] TO [% to %]
316 SELECT [% to %]_[% on %]([% arglist %])
322 method root_table () {
324 ? $self->parent_source->root_table
325 : $self->schema->source($self->raw_source_name)
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;
343 my $am_root = !($super_view || @other_parents);
345 my $select = $sqla->select(
348 : ([ # FROM _tbl _tbl
349 { $table->name => $table->name },
353 { $parent->name => $parent->name },
354 # ON _tbl.id = view.id
355 { map +(qualify_with($parent, $_), qualify_with($table, $_)),
361 [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
364 my ($now, @next) = grep defined, $super_view, $table, @other_parents;
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
372 $self->name.'_insert',
375 $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
380 $sqla->insert( # INSERT INTO parent (id, ...)
381 # VALUES (currval('_root_tbl_id_seq'), ...)
385 id => \"currval('${\$self->root_table->name}_id_seq')",
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
400 $self->name.'_update',
401 [ @pk_cols, @body_cols ],
403 $_->name, # UPDATE foo
404 { arg_hash $_ }, # SET a = _a
413 $self->name.'_delete',
415 [ map $sqla->delete($_->name, $pk_where), @sources ];
418 (rule_body insert => $self, [], \@body_cols),
419 (rule_body update => $self, \@pk_cols, \@body_cols),
420 (rule_body delete => $self, \@pk_cols, []),
422 return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
430 DBIx::Class::ResultSource::MultipleTableInheritance -- Use multiple tables to define your classes
435 package MyApp::Schema::Result::Coffee;
437 __PACKAGE__->table_class('DBIx::Class::ResultSource::MultipleTableInheritance');
438 __PACKAGE__->table('coffee');
439 __PACKAGE__->add_columns(
442 data_type => "integer",
443 default_value => "nextval('coffee_seq'::regclass)",
444 is_auto_increment => 1,
452 default_value => "good",
456 __PACKAGE__->set_primary_key("id");
462 package MyApp::Schema::Result::Sumatra;
466 __PACKAGE__->table('sumatra');
468 __PACKAGE__->add_columns(
472 default_value => undef,
482 my $schema = MyApp::Schema->connect($dsn);
484 my $cup = $schema->resultset('Sumatra')->new;
486 print STDERR Dumper $cup->columns;
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>.
495 This is accomplished through the use of stored procedures that map changes written to the view to changes to the underlying concrete tables.
500 In many applications, many classes are subclasses of others. Let's say you have this schema:
502 # Conceptual domain model
517 That's redundant. Hold on a sec...
525 class Investor extends User {
529 Good idea, but how to put this into code?
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.
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),
541 Let's not discuss that further.
543 A second, better, solution is to break out the two tables into user and investor:
545 create table "user" (
546 "id" integer not null primary key autoincrement,
547 "name" text not null,
548 "password" text not null
551 create table "investor" (
552 "id" integer not null references user("id"),
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:
558 my $user_rs = $schema->resultset('User');
559 my $new_user = $user_rs->create(
560 name => $args->{name},
561 password => $args->{password},
566 my $new_investor = $schema->resultset('Investor')->create(
568 dollars => $args->{dollars},
571 One can cope well with the second strategy, and it seems to be the most popular smart choice.
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:
578 my $new_investor = $schema->resultset('Investor')->create(
579 name => $args->{name},
580 password => $args->{password},
581 dollars => $args->{dollars},
584 And have it Just Work? The user...
587 name => $args->{name},
588 password => $args->{password},
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.
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:
595 INSERT INTO investor ("name","password","dollars") VALUES (...);
597 But using MTI, it is really this:
599 INSERT INTO _user_table ("username","password") VALUES (...);
600 INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
602 For deletes, the triggers fire in reverse, to preserve referential integrity (foreign key constraints). For instance:
604 my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
609 DELETE FROM _investor_table WHERE ("id" = ?);
610 DELETE FROM _user_table WHERE ("id" = ?);
620 MTI find the parents, if any, of your resultset class and adds them to the list of parent_sources for the table.
623 =item add_additional_parents
626 Continuing with coffee:
628 __PACKAGE__->result_source_instance->add_additional_parents(
630 MyApp::Schema::Result::Beverage
631 MyApp::Schema::Result::Liquid
635 This just lets you manually add additional parents beyond the ones MTI finds.
637 =item add_additional_parent
639 __PACKAGE__->result_source_instance->add_additional_parent(
640 MyApp::Schema::Result::Beverage
643 You can also add just one.
645 =item attach_additional_sources
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.,
651 print STDERR map { "$_\n" } MyApp::Schema->sources;
659 Raw::Sumatra will be used to generate the view.
661 =item view_definition
663 This takes the raw table and generates the view (and stored procedures) you will use.
669 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
673 Docs: Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
677 This library is free software; you can redistribute it and/or modify
678 it under the same terms as Perl itself.
683 L<DBIx::Class::ResultSource>