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 method new ($class: @args) {
  19   my $new = $class->next::method(@args);
  20   my $rc = $new->result_class;
  21   if (my $meth = $rc->can('result_source_instance')) {
  22     my $source = $rc->$meth;
  23     if ($source->result_class ne $new->result_class
  24         && $new->result_class->isa($source->result_class)) {
  25       $new->parent_source($source);
  26     }
  27   }
  28   return $new;
  29 }
  30
  31 method add_additional_parents (@classes) {
  32   foreach my $class (@classes) {
  33     Class::C3::Componentised->ensure_class_loaded($class);
  34     $self->add_additional_parent(
  35       $class->result_source_instance
  36     );
  37   }
  38 }
  39
  40 method add_additional_parent ($source) {
  41   my ($our_pk, $their_pk) = map {
  42     join('|',sort $_->primary_columns)
  43   } ($self, $source);
  44
  45   confess "Can't attach additional parent ${\$source->name} - it has different PKs ($their_pk versus our $our_pk)"
  46     unless $their_pk eq $our_pk;
  47   $self->additional_parents([
  48     @{$self->additional_parents||[]}, $source
  49   ]);
  50   $self->add_columns(
  51     map {
  52       $_ => # put the extra key first to default it
  53       { originally_defined_in => $source->name, %{$source->column_info($_)}, },
  54     } grep !$self->has_column($_), $source->columns
  55   );
  56   foreach my $rel ($source->relationships) {
  57     my $rel_info = $source->relationship_info($rel);
  58     $self->add_relationship(
  59       $rel, $rel_info->{source}, $rel_info->{cond},
  60       # extra key first to default it
  61       {originally_defined_in => $source->name, %{$rel_info->{attrs}}},
  62     );
  63   }
  64   { no strict 'refs';
  65     push(@{$self->result_class.'::ISA'}, $source->result_class);
  66   }
  67 }
  68
  69 method _source_by_name ($name) {
  70   my $schema = $self->schema;
  71   my ($source) =
  72     grep { $_->name eq $name }
  73       map $schema->source($_), $schema->sources;
  74   confess "Couldn't find attached source for parent $name - did you use load_classes? This module is only compatible with load_namespaces"
  75     unless $source;
  76   return $source;
  77 }
  78
  79 method schema (@args) {
  80   my $ret = $self->next::method(@args);
  81   if (@args) {
  82     if ($self->parent_source) {
  83       my $parent_name = $self->parent_source->name;
  84       $self->parent_source($self->_source_by_name($parent_name));
  85     }
  86     $self->additional_parents([
  87       map { $self->_source_by_name($_->name) }
  88       @{$self->additional_parents||[]}
  89     ]);
  90   }
  91   return $ret;
  92 }
  93
  94 method attach_additional_sources () {
  95   my $raw_name = $self->raw_source_name;
  96   my $schema = $self->schema;
  97
  98   # if the raw source is already present we can assume we're done
  99   return if grep { $_ eq $raw_name } $schema->sources;
 100
 101   # our parent should've been registered already actually due to DBIC
 102   # attaching subclass sources later in load_namespaces
 103
 104   my $parent;
 105   if ($self->parent_source) {
 106       my $parent_name = $self->parent_source->name;
 107     ($parent) =
 108       grep { $_->name eq $parent_name }
 109         map $schema->source($_), $schema->sources;
 110     confess "Couldn't find attached source for parent $parent_name - did you use load_classes? This module is only compatible with load_namespaces"
 111       unless $parent;
 112     $self->parent_source($parent); # so our parent is the one in this schema
 113   }
 114
 115   # create the raw table source
 116
 117   my $table = Table->new({ name => $self->raw_table_name });
 118
 119   # we don't need to add the PK cols explicitly if we're the root table
 120   # since they'll get added below
 121
 122   my %pk_join;
 123
 124   if ($parent) {
 125     foreach my $pri ($self->primary_columns) {
 126       my %info = %{$self->column_info($pri)};
 127       delete @info{qw(is_auto_increment sequence auto_nextval)};
 128       $table->add_column($pri => \%info);
 129       $pk_join{"foreign.${pri}"} = "self.${pri}";
 130     }
 131     # have to use source name lookups rather than result class here
 132     # because we don't actually have a result class on the raw sources
 133     $table->add_relationship('parent', $parent->raw_source_name, \%pk_join);
 134     $self->depends_on->{$parent->source_name} = 1;
 135   }
 136
 137   foreach my $add (@{$self->additional_parents||[]}) {
 138     $table->add_relationship(
 139       'parent_'.$add->name, $add->source_name, \%pk_join
 140     );
 141     $self->depends_on->{$add->source_name} = 1;
 142   }
 143
 144   # add every column that's actually a concrete part of us
 145
 146   $table->add_columns(
 147     map { ($_ => { %{$self->column_info($_)} }) }
 148       grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
 149         $self->columns
 150   );
 151   $table->set_primary_key($self->primary_columns);
 152
 153   # we need to copy our rels to the raw object as well
 154   # note that ->add_relationship on a source object doesn't create an
 155   # accessor so we can leave that part in the attributes
 156
 157   # if the other side is a table then we need to copy any rels it has
 158   # back to us, as well, so that they point at the raw table. if the
 159   # other side is an MTI view then we need to create the rels to it to
 160   # point at -its- raw table; we don't need to worry about backrels because
 161   # it's going to run this method too (and its raw source might not exist
 162   # yet so we can't, anyway)
 163
 164   foreach my $rel ($self->relationships) {
 165     my $rel_info = $self->relationship_info($rel);
 166
 167     # if we got this from the superclass, -its- raw table will nail this.
 168     # if we got it from an additional parent, it's its problem.
 169     next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;
 170
 171     my $f_source = $schema->source($rel_info->{source});
 172
 173     # __PACKAGE__ is correct here because subclasses should be caught
 174
 175     my $one_of_us = $f_source->isa(__PACKAGE__);
 176
 177     my $f_source_name = $f_source->${\
 178                         ($one_of_us ? 'raw_source_name' : 'source_name')
 179                       };
 180
 181     $table->add_relationship(
 182       '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
 183     );
 184
 185     unless ($one_of_us) {
 186       my $reverse = do {
 187         # we haven't been registered yet, so reverse_ cries
 188         # XXX this is evil and will probably break eventually
 189         local @{$schema->source_registrations}
 190                {map $self->$_, qw(source_name result_class)}
 191           = ($self, $self);
 192         $self->reverse_relationship_info($rel);
 193       };
 194       foreach my $rev_rel (keys %$reverse) {
 195         $f_source->add_relationship(
 196           '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
 197         );
 198       }
 199     }
 200   }
 201
 202   $schema->register_source($raw_name => $table);
 203 }
 204
 205 method set_primary_key (@args) {
 206   if ($self->parent_source) {
 207     confess "Can't set primary key on a subclass";
 208   }
 209   return $self->next::method(@args);
 210 }
 211
 212 method raw_source_name () {
 213   my $base = $self->source_name;
 214   confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
 215     unless $base;
 216   return 'Raw::'.$base;
 217 }
 218
 219 method raw_table_name () {
 220   return '_'.$self->name;
 221 }
 222
 223 method add_columns (@args) {
 224   my $ret = $self->next::method(@args);
 225   $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
 226   return $ret;
 227 }
 228
 229 method add_relationship ($name, $f_source, $cond, $attrs) {
 230   $self->next::method(
 231     $name, $f_source, $cond,
 232     { originally_defined_in => $self->name, %{$attrs||{}}, }
 233   );
 234 }
 235
 236 BEGIN {
 237
 238   # helper routines, constructed as anon subs so autoclean nukes them
 239
 240   use signatures;
 241
 242   *argify = sub (@names) {
 243     map '_'.$_, @names;
 244   };
 245
 246   *qualify_with = sub ($source, @names) {
 247     my $name = blessed($source) ? $source->name : $source;
 248     map join('.', $name, $_), @names;
 249   };
 250
 251   *body_cols = sub ($source) {
 252     my %pk; @pk{$source->primary_columns} = ();
 253     map +{ %{$source->column_info($_)}, name => $_ },
 254       grep !exists $pk{$_}, $source->columns;
 255   };
 256
 257   *pk_cols = sub ($source) {
 258     map +{ %{$source->column_info($_)}, name => $_ },
 259       $source->primary_columns;
 260   };
 261
 262   *names_of = sub (@cols) { map $_->{name}, @cols };
 263
 264   *function_body = sub ($name, $args, $body_parts) {
 265     my $arglist = join(
 266       ', ',
 267         map "_${\$_->{name}} ${\uc($_->{data_type})}",
 268           @$args
 269     );
 270     my $body = join("\n", '', map "          $_;", @$body_parts);
 271     return strip tt q{
 272       CREATE OR REPLACE FUNCTION [% name %]
 273         ([% arglist %])
 274         RETURNS VOID AS $function$
 275         BEGIN
 276           [%- body %]
 277         END;
 278       $function$ LANGUAGE plpgsql;
 279     };
 280   };
 281 }
 282
 283 BEGIN {
 284
 285   use signatures;
 286
 287   *arg_hash = sub ($source) {
 288     map +($_ => \(argify $_)), names_of body_cols $source;
 289   };
 290
 291   *rule_body = sub ($on, $to, $oldlist, $newlist) {
 292     my $arglist = join(', ',
 293       (qualify_with 'OLD', names_of @$oldlist),
 294       (qualify_with 'NEW', names_of @$newlist),
 295     );
 296     $to = $to->name if blessed($to);
 297     return strip tt q{
 298       CREATE RULE _[% to %]_[% on %]_rule AS
 299         ON [% on | upper %] TO [% to %]
 300         DO INSTEAD (
 301           SELECT [% to %]_[% on %]([% arglist %])
 302         );
 303     };
 304   };
 305 }
 306
 307 method root_table () {
 308   $self->parent_source
 309     ? $self->parent_source->root_table
 310     : $self->schema->source($self->raw_source_name)
 311 }
 312
 313 method view_definition () {
 314   my $schema = $self->schema;
 315   confess "Can't generate view without connected schema, sorry"
 316     unless $schema && $schema->storage;
 317   my $sqla = $schema->storage->sql_maker;
 318   my $table = $self->schema->source($self->raw_source_name);
 319   my $super_view = $self->parent_source;
 320   my @all_parents = my @other_parents = @{$self->additional_parents||[]};
 321   push(@all_parents, $super_view) if defined($super_view);
 322   my @sources = ($table, @all_parents);
 323   my @body_cols = map body_cols($_), @sources;
 324   my @pk_cols = pk_cols $self;
 325
 326   # SELECT statement
 327
 328   my $am_root = !($super_view || @other_parents);
 329
 330   my $select = $sqla->select(
 331     ($am_root
 332       ? ($table->name)
 333       : ([   # FROM _tbl _tbl
 334            { $table->name => $table->name },
 335            map {
 336              my $parent = $_;
 337              [ # JOIN view view
 338                { $parent->name => $parent->name },
 339                # ON _tbl.id = view.id
 340                { map +(qualify_with($parent, $_), qualify_with($table, $_)),
 341                    names_of @pk_cols }
 342              ]
 343            } @all_parents
 344          ])
 345       ),
 346     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
 347   ).';';
 348
 349   my ($now, @next) = grep defined, $super_view, $table, @other_parents;
 350
 351   # INSERT function
 352
 353   # NOTE: this assumes a single PK col called id with a sequence somewhere
 354   # but nothing else -should- so fixing this should make everything work
 355   my $insert_func =
 356     function_body
 357       $self->name.'_insert',
 358       \@body_cols,
 359       [
 360         $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
 361           $now->name,
 362           { arg_hash $now },
 363         ),
 364         (map {
 365           $sqla->insert( # INSERT INTO parent (id, ...)
 366                          #   VALUES (currval('_root_tbl_id_seq'), ...)
 367             $_->name,
 368             {
 369               (arg_hash $_),
 370               id => \"currval('${\$self->root_table->name}_id_seq')",
 371             }
 372           )
 373         } @next)
 374       ];
 375
 376   # note - similar to arg_hash but not quite enough to share code sanely
 377   my $pk_where = { # id = _id AND id2 = _id2 ...
 378     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
 379   };
 380
 381   # UPDATE function
 382
 383   my $update_func =
 384     function_body
 385       $self->name.'_update',
 386       [ @pk_cols, @body_cols ],
 387       [ map $sqla->update(
 388           $_->name, # UPDATE foo
 389           { arg_hash $_ }, # SET a = _a
 390           $pk_where,
 391         ), @sources
 392       ];
 393
 394   # DELETE function
 395
 396   my $delete_func =
 397     function_body
 398       $self->name.'_delete',
 399       [ @pk_cols ],
 400       [ map $sqla->delete($_->name, $pk_where), @sources ];
 401
 402   my @rules = (
 403     (rule_body insert => $self, [], \@body_cols),
 404     (rule_body update => $self, \@pk_cols, \@body_cols),
 405     (rule_body delete => $self, \@pk_cols, []),
 406   );
 407   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
 408 }
 409
 410 1;
 411
 412 __END__
 413
 414 # how this works:
 415 #
 416 # On construction, we hook $self->result_class->result_source_instance
 417 # if present to get the superclass' source object
 418 #
 419 # When attached to a schema, we need to add sources to that schema with
 420 # appropriate relationships for the foreign keys so the concrete tables
 421 # get generated
 422 #
 423 # We also generate our own view definition using this class' concrete table
 424 # and the view for the superclass, and stored procedures for the insert,
 425 # update and delete operations on this view.
 426 #
 427 # deploying the postgres rules through SQLT may be a pain though.
 428
 429 =encoding utf-8
 430
 431 =head1 NAME
 432
 433 DBIx::Class::ResultSource::MultipleTableInheritance -- Use multiple tables to define your classes
 434
 435 =head1 SYNOPSIS
 436
 437
 438     {
 439         package MyApp::Schema::Result::Coffee;
 440
 441         __PACKAGE__->table_class('DBIx::Class::ResultSource::MultipleTableInheritance');
 442         __PACKAGE__->table('coffee');
 443         __PACKAGE__->add_columns(
 444           "id",
 445           {
 446             data_type => "integer",
 447             default_value => "nextval('coffee_seq'::regclass)",
 448             is_auto_increment => 1,
 449             is_foreign_key => 1,
 450             is_nullable => 0,
 451             size => 4,
 452           },
 453           "flavor",
 454           {
 455             data_type => "text",
 456             default_value => "good",
 457           },
 458         );
 459
 460         __PACKAGE__->set_primary_key("id");
 461
 462         1;
 463     }
 464
 465     {
 466         package MyApp::Schema::Result::Sumatra;
 467
 468         use parent 'Coffee';
 469
 470         __PACKAGE__->table('sumatra');
 471
 472         __PACKAGE__->add_columns(
 473           "aroma",
 474           {
 475             data_type => "text",
 476             default_value => undef,
 477             is_nullable => 0,
 478           },
 479         );
 480
 481         1;
 482     }
 483
 484     ...
 485
 486     my $schema = MyApp::Schema->connect($dsn);
 487
 488     my $cup = $schema->resultset('Sumatra')->new;
 489
 490     print STDERR Dumper $cup->columns;
 491
 492         $VAR1 = 'id';
 493         $VAR2 = 'flavor';
 494         $VAR3 = 'aroma';
 495
 496
 497
 498 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<transparentlt writable>.
 499
 500 This is accomplished through the use of stored functions that map changes written to the view to changes to the underlying concrete tables.
 501
 502 =head1 WHY?
 503
 504 In many applications, many classes are subclasses of others. Let's say you have this schema:
 505
 506     # Conceptual domain model
 507
 508     class User {
 509             has id,
 510             has name,
 511             has password
 512     }
 513
 514     class Investor {
 515         has id,
 516         has name,
 517         has password,
 518         has dollars
 519     }
 520
 521 That's redundant. Hold on a sec...
 522
 523     class User {
 524             has id,
 525             has name,
 526             has password
 527     }
 528
 529     class Investor isa User {
 530         has dollars
 531     }
 532
 533 Good idea, but how to put this into code?
 534
 535 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.
 536
 537     create table "user" (
 538         "id" integer not null primary key autoincrement,
 539         "name" text not null,
 540         "password" text not null,
 541         "investor" tinyint(1),
 542         "dollars" integer
 543     );
 544
 545 Let's not discuss that further.
 546
 547 A second, better, solution is to break out the two tables into user and investor:
 548
 549     create table "user" (
 550         "id" integer not null primary key autoincrement,
 551         "name" text not null,
 552         "password" text not null
 553     );
 554
 555     create table "investor" (
 556         "id" integer not null references user("id"),
 557         "dollars" integer
 558     );
 559
 560 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:
 561
 562     my $user_rs = $schema->resultset('User');
 563     my $new_user = $user_rs->create(
 564         name => $args->{name},
 565         password => $args->{password},
 566     );
 567
 568     ...
 569
 570     my $new_investor = $schema->resultset('Investor')->create(
 571         id => $new_user->id,
 572         dollars => $args->{dollars},
 573     );
 574
 575 One can cope well with the second strategy, and it seems to be the most popular smart choice.
 576
 577 =head1 HOW?
 578
 579 There is a third strategy implemented here. Make the database do more of the work. It'll save us some typing and it'll make for more expressive code. What if we could do this:
 580
 581     my $new_investor = $schema->resultset('Investor')->create(
 582         name => $args->{name},
 583         password => $args->{password},
 584         dollars => $args->{dollars},
 585     );
 586
 587 And have it Just Work? The user ( {name => $args->{name}, password => $args->{password} } ) should be created transparently, 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.
 588
 589 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:
 590
 591     INSERT INTO investor ("name","password","dollars") VALUES (...);
 592
 593 But using MTI, it is really this:
 594
 595     INSERT INTO _user_table ("username","password") VALUES (...);
 596     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
 597
 598 For deletes, the triggers fire in reverse, to preserve referential integrity (foreign key constraints). For instance:
 599
 600    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
 601    $investor->delete;
 602
 603 Becomes:
 604
 605     DELETE FROM _investor_table WHERE ("id" = ?);
 606     DELETE FROM _user_table WHERE ("id" = ?);
 607
 608
 609
 610
 611
 612
 613
 614
 615 =head1 AUTHOR
 616
 617 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
 618
 619 =head2 CONTRIBUTORS
 620
 621 Docs: Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
 622
 623 =head1 LICENSE
 624
 625 This library is free software; you can redistribute it and/or modify
 626 it under the same terms as Perl itself.
 627
 628 =head1 SEE ALSO
 629
 630 L<DBIx::Class>
 631 L<DBIx::Class::ResultSource>
 632
 633 =cut