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->deploy_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->deploy_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
 429 =head1 NAME
 430
 431 DBIx::Class::ResultSource::MultipleTableInheritance
 432 Use multiple tables to define your classes
 433
 434 =head1 NOTICE
 435
 436 This only works with PostgreSQL for the moment.
 437
 438 =head1 SYNOPSIS
 439
 440     {
 441         package MyApp::Schema::Result::Coffee;
 442
 443         __PACKAGE__->table_class(
 444             'DBIx::Class::ResultSource::MultipleTableInheritance'
 445         );
 446         __PACKAGE__->table('coffee');
 447         __PACKAGE__->add_columns(
 448           "id",
 449           {
 450             data_type => "integer",
 451             default_value => "nextval('coffee_seq'::regclass)",
 452             is_auto_increment => 1,
 453             is_foreign_key => 1,
 454             is_nullable => 0,
 455             size => 4,
 456           },
 457           "flavor",
 458           {
 459             data_type => "text",
 460             default_value => "good",
 461           },
 462         );
 463
 464         __PACKAGE__->set_primary_key("id");
 465
 466         1;
 467     }
 468
 469     {
 470         package MyApp::Schema::Result::Sumatra;
 471
 472         use parent 'Coffee';
 473
 474         __PACKAGE__->table('sumatra');
 475
 476         __PACKAGE__->add_columns(
 477           "aroma",
 478           {
 479             data_type => "text",
 480             default_value => undef,
 481             is_nullable => 0,
 482           },
 483         );
 484
 485         1;
 486     }
 487
 488     ...
 489
 490     my $schema = MyApp::Schema->connect($dsn);
 491
 492     my $cup = $schema->resultset('Sumatra')->new;
 493
 494     print STDERR DwarnS $cup->columns;
 495
 496         $VAR1 = 'id';
 497         $VAR2 = 'flavor';
 498         $VAR3 = 'aroma';
 499
 500
 501 Inherit from this package and you can make a resultset class from a view, but
 502 that's more than a little bit misleading: the result is B<transparently
 503 writable>.
 504
 505 This is accomplished through the use of stored procedures that map changes
 506 written to the view to changes to the underlying concrete tables.
 507
 508 =head1 WHY?
 509
 510 In many applications, many classes are subclasses of others. Let's say you
 511 have this schema:
 512
 513     # Conceptual domain model
 514
 515     class User {
 516         has id,
 517         has name,
 518         has password
 519     }
 520
 521     class Investor {
 522         has id,
 523         has name,
 524         has password,
 525         has dollars
 526     }
 527
 528 That's redundant. Hold on a sec...
 529
 530     class User {
 531         has id,
 532         has name,
 533         has password
 534     }
 535
 536     class Investor extends User {
 537         has dollars
 538     }
 539
 540 Good idea, but how to put this into code?
 541
 542 One far-too common and absolutely horrendous solution is to have a "checkbox"
 543 in your database: a nullable "investor" column, which entails a nullable
 544 "dollars" column, in the user table.
 545
 546     create table "user" (
 547         "id" integer not null primary key autoincrement,
 548         "name" text not null,
 549         "password" text not null,
 550         "investor" tinyint(1),
 551         "dollars" integer
 552     );
 553
 554 Let's not discuss that further.
 555
 556 A second, better, solution is to break out the two tables into user and
 557 investor:
 558
 559     create table "user" (
 560         "id" integer not null primary key autoincrement,
 561         "name" text not null,
 562         "password" text not null
 563     );
 564
 565     create table "investor" (
 566         "id" integer not null references user("id"),
 567         "dollars" integer
 568     );
 569
 570 So that investor's PK is just an FK to the user. We can clearly see the class
 571 hierarchy here, in which investor is a subclass of user. In DBIx::Class
 572 applications, this second strategy looks like:
 573
 574     my $user_rs = $schema->resultset('User');
 575     my $new_user = $user_rs->create(
 576         name => $args->{name},
 577         password => $args->{password},
 578     );
 579
 580     ...
 581
 582     my $new_investor = $schema->resultset('Investor')->create(
 583         id => $new_user->id,
 584         dollars => $args->{dollars},
 585     );
 586
 587 One can cope well with the second strategy, and it seems to be the most popular
 588 smart choice.
 589
 590 =head1 HOW?
 591
 592 There is a third strategy implemented here. Make the database do more of the
 593 work: hide the nasty bits so we don't have to handle them unless we really want
 594 to. It'll save us some typing and it'll make for more expressive code. What if
 595 we could do this:
 596
 597     my $new_investor = $schema->resultset('Investor')->create(
 598         name => $args->{name},
 599         password => $args->{password},
 600         dollars => $args->{dollars},
 601     );
 602
 603 And have it Just Work? The user...
 604
 605     {
 606         name => $args->{name},
 607         password => $args->{password},
 608     }
 609
 610 should be created behind the scenes, and the use of either user or investor
 611 in your code should require no special handling. Deleting and updating
 612 $new_investor should also delete or update the user row.
 613
 614 It does. User and investor are both views, their concrete tables abstracted
 615 away behind a set of rules and triggers. You would expect the above DBIC
 616 create statement to look like this in SQL:
 617
 618     INSERT INTO investor ("name","password","dollars") VALUES (...);
 619
 620 But using MTI, it is really this:
 621
 622     INSERT INTO _user_table ("username","password") VALUES (...);
 623     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
 624
 625 For deletes, the triggers fire in reverse, to preserve referential integrity
 626 (foreign key constraints). For instance:
 627
 628    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
 629    $investor->delete;
 630
 631 Becomes:
 632
 633     DELETE FROM _investor_table WHERE ("id" = ?);
 634     DELETE FROM _user_table WHERE ("id" = ?);
 635
 636
 637 =head1 METHODS
 638
 639 =over
 640
 641 =item new
 642
 643
 644 MTI find the parents, if any, of your resultset class and adds them to the
 645 list of parent_sources for the table.
 646
 647
 648 =item add_additional_parents
 649
 650
 651 Continuing with coffee:
 652
 653     __PACKAGE__->result_source_instance->add_additional_parents(
 654         qw/
 655             MyApp::Schema::Result::Beverage
 656             MyApp::Schema::Result::Liquid
 657         /
 658     );
 659
 660 This just lets you manually add additional parents beyond the ones MTI finds.
 661
 662 =item add_additional_parent
 663
 664     __PACKAGE__->result_source_instance->add_additional_parent(
 665             MyApp::Schema::Result::Beverage
 666     );
 667
 668 You can also add just one.
 669
 670 =item attach_additional_sources
 671
 672 MTI takes the parents' sources and relationships, creates a new
 673 DBIx::Class::Table object from them, and registers this as a new, raw, source
 674 in the schema, e.g.,
 675
 676     use MyApp::Schema;
 677
 678     print STDERR map { "$_\n" } MyApp::Schema->sources;
 679
 680     # Coffee
 681     # Beverage
 682     # Liquid
 683     # Sumatra
 684     # Raw::Sumatra
 685
 686 Raw::Sumatra will be used to generate the view.
 687
 688 =item view_definition
 689
 690 This takes the raw table and generates the view (and stored procedures) you will use.
 691
 692 =back
 693
 694 =head1 AUTHOR
 695
 696 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
 697
 698 =head2 CONTRIBUTORS
 699
 700 Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
 701
 702 =head1 COPYRIGHT
 703
 704 Copyright (c) 2010 the DBIx::Class::ResultSource::MultipleTableInheritance
 705 L</AUTHOR> and L</CONTRIBUTORS> as listed above.
 706
 707 =head1 LICENSE
 708
 709 This library is free software; you can redistribute it and/or modify
 710 it under the same terms as Perl itself.
 711
 712 =head1 SEE ALSO
 713
 714 L<DBIx::Class>
 715 L<DBIx::Class::ResultSource>
 716
 717 =cut