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->result_class} = 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->result_class} = 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   # Attempting to re-add sequence here -- AKB
 169   for my $pk ( $self->primary_columns ) {
 170     $table->columns_info->{$pk}->{sequence} =
 171       $self->set_sequence( $table->name, $self->primary_columns )
 172       unless grep {
 173       $table->columns_info->{$_}->{originally_defined_in} ne $self->name
 174       } keys %{ $table->columns_info };
 175   }
 176
 177   # we need to copy our rels to the raw object as well
 178   # note that ->add_relationship on a source object doesn't create an
 179   # accessor so we can leave that part in the attributes
 180
 181   # if the other side is a table then we need to copy any rels it has
 182   # back to us, as well, so that they point at the raw table. if the
 183   # other side is an MTI view then we need to create the rels to it to
 184   # point at -its- raw table; we don't need to worry about backrels because
 185   # it's going to run this method too (and its raw source might not exist
 186   # yet so we can't, anyway)
 187
 188   foreach my $rel ($self->relationships) {
 189     my $rel_info = $self->relationship_info($rel);
 190
 191     # if we got this from the superclass, -its- raw table will nail this.
 192     # if we got it from an additional parent, it's its problem.
 193     next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;
 194
 195     my $f_source = $schema->source($rel_info->{source});
 196
 197     # __PACKAGE__ is correct here because subclasses should be caught
 198
 199     my $one_of_us = $f_source->isa(__PACKAGE__);
 200
 201     my $f_source_name = $f_source->${\
 202                         ($one_of_us ? 'raw_source_name' : 'source_name')
 203                       };
 204
 205     $table->add_relationship(
 206       '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
 207     );
 208
 209     unless ($one_of_us) {
 210       my $reverse = do {
 211         # we haven't been registered yet, so reverse_ cries
 212         # XXX this is evil and will probably break eventually
 213         local @{$schema->source_registrations}
 214                {map $self->$_, qw(source_name result_class)}
 215           = ($self, $self);
 216         $self->reverse_relationship_info($rel);
 217       };
 218       foreach my $rev_rel (keys %$reverse) {
 219         $f_source->add_relationship(
 220           '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
 221         );
 222       }
 223     }
 224   }
 225
 226   $schema->register_source($raw_name => $table);
 227 }
 228
 229 method set_primary_key (@args) {
 230   if ($self->parent_source) {
 231     confess "Can't set primary key on a subclass";
 232   }
 233   return $self->next::method(@args);
 234 }
 235
 236 method set_sequence ($table_name, @pks) {
 237   return $table_name . '_' . join('_',@pks) . '_' . 'seq';
 238 }
 239
 240 method raw_source_name () {
 241   my $base = $self->source_name;
 242   confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
 243     unless $base;
 244   return 'Raw::'.$base;
 245 }
 246
 247 method raw_table_name () {
 248   return '_'.$self->name;
 249 }
 250
 251 method add_columns (@args) {
 252   my $ret = $self->next::method(@args);
 253   $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
 254   return $ret;
 255 }
 256
 257 method add_relationship ($name, $f_source, $cond, $attrs) {
 258   $self->next::method(
 259     $name, $f_source, $cond,
 260     { originally_defined_in => $self->name, %{$attrs||{}}, }
 261   );
 262 }
 263
 264 BEGIN {
 265
 266   # helper routines, constructed as anon subs so autoclean nukes them
 267
 268   use signatures;
 269
 270   *argify = sub (@names) {
 271     map '_'.$_, @names;
 272   };
 273
 274   *qualify_with = sub ($source, @names) {
 275     my $name = blessed($source) ? $source->name : $source;
 276     map join('.', $name, $_), @names;
 277   };
 278
 279   *body_cols = sub ($source) {
 280     my %pk; @pk{$source->primary_columns} = ();
 281     map +{ %{$source->column_info($_)}, name => $_ },
 282       grep !exists $pk{$_}, $source->columns;
 283   };
 284
 285   *pk_cols = sub ($source) {
 286     map +{ %{$source->column_info($_)}, name => $_ },
 287       $source->primary_columns;
 288   };
 289
 290   *names_of = sub (@cols) { map $_->{name}, @cols };
 291
 292   *function_body = sub {
 293     my ($name,$args,$body_parts) = @_;
 294     my $arglist = join(
 295       ', ',
 296         map "_${\$_->{name}} ${\uc($_->{data_type})}",
 297           @$args
 298     );
 299     my $body = join("\n", '', map "          $_;", @$body_parts);
 300     return strip tt q{
 301       CREATE OR REPLACE FUNCTION [% name %]
 302         ([% arglist %])
 303         RETURNS VOID AS $function$
 304         BEGIN
 305           [%- body %]
 306         END;
 307       $function$ LANGUAGE plpgsql;
 308     };
 309   };
 310   #*function_body = sub ($name,$args,$body_parts) {
 311     #my $arglist = join(
 312       #', ',
 313         #map "_${\$_->{name}} ${\uc($_->{data_type})}",
 314           #@$args
 315     #);
 316     #my $body = join("\n", '', map "          $_;", @$body_parts);
 317     #return strip tt q{
 318       #CREATE OR REPLACE FUNCTION [% name %]
 319         #([% arglist %])
 320         #RETURNS VOID AS $function$
 321         #BEGIN
 322           #[%- body %]
 323         #END;
 324       #$function$ LANGUAGE plpgsql;
 325     #};
 326   #};
 327 }
 328
 329 BEGIN {
 330
 331   use signatures;
 332
 333   *arg_hash = sub ($source) {
 334     map +($_ => \(argify $_)), names_of body_cols $source;
 335   };
 336
 337   *rule_body = sub ($on, $to, $oldlist, $newlist) {
 338     my $arglist = join(', ',
 339       (qualify_with 'OLD', names_of @$oldlist),
 340       (qualify_with 'NEW', names_of @$newlist),
 341     );
 342     $to = $to->name if blessed($to);
 343     return strip tt q{
 344       CREATE RULE _[% to %]_[% on %]_rule AS
 345         ON [% on | upper %] TO [% to %]
 346         DO INSTEAD (
 347           SELECT [% to %]_[% on %]([% arglist %])
 348         );
 349     };
 350   };
 351 }
 352
 353 method root_table () {
 354   $self->parent_source
 355     ? $self->parent_source->root_table
 356     : $self->schema->source($self->raw_source_name)
 357 }
 358
 359 method view_definition () {
 360   my $schema = $self->schema;
 361   confess "Can't generate view without connected schema, sorry"
 362     unless $schema && $schema->storage;
 363   my $sqla = $schema->storage->sql_maker;
 364   my $table = $self->schema->source($self->raw_source_name);
 365   my $super_view = $self->parent_source;
 366   my @all_parents = my @other_parents = @{$self->additional_parents||[]};
 367   push(@all_parents, $super_view) if defined($super_view);
 368   my @sources = ($table, @all_parents);
 369   my @body_cols = map body_cols($_), @sources;
 370   my @pk_cols = pk_cols $self;
 371
 372   # SELECT statement
 373
 374   my $am_root = !($super_view || @other_parents);
 375
 376   my $select = $sqla->select(
 377     ($am_root
 378       ? ($table->name)
 379       : ([   # FROM _tbl _tbl
 380            { $table->name => $table->name },
 381            map {
 382              my $parent = $_;
 383              [ # JOIN view view
 384                { $parent->name => $parent->name },
 385                # ON _tbl.id = view.id
 386                { map +(qualify_with($parent, $_), qualify_with($table, $_)),
 387                    names_of @pk_cols }
 388              ]
 389            } @all_parents
 390          ])
 391       ),
 392     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
 393   ).';';
 394
 395   my ($now, @next) = grep defined, $super_view, $table, @other_parents;
 396
 397   # INSERT function
 398
 399   # NOTE: this assumes a single PK col called id with a sequence somewhere
 400   # but nothing else -should- so fixing this should make everything work
 401   my $insert_func =
 402     function_body
 403       $self->name.'_insert',
 404       \@body_cols,
 405       [
 406         $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
 407           $now->name,
 408           { arg_hash $now },
 409         ),
 410         (map {
 411           $sqla->insert( # INSERT INTO parent (id, ...)
 412                          #   VALUES (currval('_root_tbl_id_seq'), ...)
 413             $_->name,
 414             {
 415               (arg_hash $_),
 416               id => \"currval('${\$self->root_table->name}_id_seq')",
 417             }
 418           )
 419         } @next)
 420       ];
 421
 422   # note - similar to arg_hash but not quite enough to share code sanely
 423   my $pk_where = { # id = _id AND id2 = _id2 ...
 424     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
 425   };
 426
 427   # UPDATE function
 428
 429   my $update_func =
 430     function_body
 431       $self->name.'_update',
 432       [ @pk_cols, @body_cols ],
 433       [ map $sqla->update(
 434           $_->name, # UPDATE foo
 435           { arg_hash $_ }, # SET a = _a
 436           $pk_where,
 437         ), @sources
 438       ];
 439
 440   # DELETE function
 441
 442   my $delete_func =
 443     function_body
 444       $self->name.'_delete',
 445       [ @pk_cols ],
 446       [ map $sqla->delete($_->name, $pk_where), @sources ];
 447
 448   my @rules = (
 449     (rule_body insert => $self, [], \@body_cols),
 450     (rule_body update => $self, \@pk_cols, \@body_cols),
 451     (rule_body delete => $self, \@pk_cols, []),
 452   );
 453   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
 454 }
 455
 456 1;
 457
 458 __END__
 459
 460 =head1 NAME
 461
 462 DBIx::Class::ResultSource::MultipleTableInheritance
 463 Use multiple tables to define your classes
 464
 465 =head1 NOTICE
 466
 467 This only works with PostgreSQL for the moment.
 468
 469 =head1 SYNOPSIS
 470
 471     {
 472         package Cafe::Result::Coffee;
 473
 474         use strict;
 475         use warnings;
 476         use parent 'DBIx::Class::Core';
 477         use aliased 'DBIx::Class::ResultSource::MultipleTableInheritance'
 478             => 'MTI';
 479
 480         __PACKAGE__->table_class(MTI);
 481         __PACKAGE__->table('coffee');
 482         __PACKAGE__->add_columns(
 483             "id", { data_type => "integer" },
 484             "flavor", {
 485                 data_type => "text",
 486                 default_value => "good" },
 487         );
 488
 489         __PACKAGE__->set_primary_key("id");
 490
 491         1;
 492     }
 493
 494     {
 495         package Cafe::Result::Sumatra;
 496
 497         use parent 'Cafe::Result::Coffee';
 498
 499         __PACKAGE__->table('sumatra');
 500
 501         __PACKAGE__->add_columns( "aroma",
 502             { data_type => "text" }
 503         );
 504
 505         1;
 506     }
 507
 508     ...
 509
 510     my $schema = Cafe->connect($dsn,$user,$pass);
 511
 512     my $cup = $schema->resultset('Sumatra');
 513
 514     print STDERR Dwarn $cup->result_source->columns;
 515
 516         "id"
 517         "flavor"
 518         "aroma"
 519         ..
 520
 521 Inherit from this package and you can make a resultset class from a view, but
 522 that's more than a little bit misleading: the result is B<transparently
 523 writable>.
 524
 525 This is accomplished through the use of stored procedures that map changes
 526 written to the view to changes to the underlying concrete tables.
 527
 528 =head1 WHY?
 529
 530 In many applications, many classes are subclasses of others. Let's say you
 531 have this schema:
 532
 533     # Conceptual domain model
 534
 535     class User {
 536         has id,
 537         has name,
 538         has password
 539     }
 540
 541     class Investor {
 542         has id,
 543         has name,
 544         has password,
 545         has dollars
 546     }
 547
 548 That's redundant. Hold on a sec...
 549
 550     class User {
 551         has id,
 552         has name,
 553         has password
 554     }
 555
 556     class Investor extends User {
 557         has dollars
 558     }
 559
 560 Good idea, but how to put this into code?
 561
 562 One far-too common and absolutely horrendous solution is to have a "checkbox"
 563 in your database: a nullable "investor" column, which entails a nullable
 564 "dollars" column, in the user table.
 565
 566     create table "user" (
 567         "id" integer not null primary key autoincrement,
 568         "name" text not null,
 569         "password" text not null,
 570         "investor" tinyint(1),
 571         "dollars" integer
 572     );
 573
 574 Let's not discuss that further.
 575
 576 A second, better, solution is to break out the two tables into user and
 577 investor:
 578
 579     create table "user" (
 580         "id" integer not null primary key autoincrement,
 581         "name" text not null,
 582         "password" text not null
 583     );
 584
 585     create table "investor" (
 586         "id" integer not null references user("id"),
 587         "dollars" integer
 588     );
 589
 590 So that investor's PK is just an FK to the user. We can clearly see the class
 591 hierarchy here, in which investor is a subclass of user. In DBIx::Class
 592 applications, this second strategy looks like:
 593
 594     my $user_rs = $schema->resultset('User');
 595     my $new_user = $user_rs->create(
 596         name => $args->{name},
 597         password => $args->{password},
 598     );
 599
 600     ...
 601
 602     my $new_investor = $schema->resultset('Investor')->create(
 603         id => $new_user->id,
 604         dollars => $args->{dollars},
 605     );
 606
 607 One can cope well with the second strategy, and it seems to be the most popular
 608 smart choice.
 609
 610 =head1 HOW?
 611
 612 There is a third strategy implemented here. Make the database do more of the
 613 work: hide the nasty bits so we don't have to handle them unless we really want
 614 to. It'll save us some typing and it'll make for more expressive code. What if
 615 we could do this:
 616
 617     my $new_investor = $schema->resultset('Investor')->create(
 618         name => $args->{name},
 619         password => $args->{password},
 620         dollars => $args->{dollars},
 621     );
 622
 623 And have it Just Work? The user...
 624
 625     {
 626         name => $args->{name},
 627         password => $args->{password},
 628     }
 629
 630 should be created behind the scenes, and the use of either user or investor
 631 in your code should require no special handling. Deleting and updating
 632 $new_investor should also delete or update the user row.
 633
 634 It does. User and investor are both views, their concrete tables abstracted
 635 away behind a set of rules and triggers. You would expect the above DBIC
 636 create statement to look like this in SQL:
 637
 638     INSERT INTO investor ("name","password","dollars") VALUES (...);
 639
 640 But using MTI, it is really this:
 641
 642     INSERT INTO _user_table ("username","password") VALUES (...);
 643     INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );
 644
 645 For deletes, the triggers fire in reverse, to preserve referential integrity
 646 (foreign key constraints). For instance:
 647
 648    my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
 649    $investor->delete;
 650
 651 Becomes:
 652
 653     DELETE FROM _investor_table WHERE ("id" = ?);
 654     DELETE FROM _user_table WHERE ("id" = ?);
 655
 656
 657 =head1 METHODS
 658
 659 =over
 660
 661 =item new
 662
 663
 664 MTI find the parents, if any, of your resultset class and adds them to the
 665 list of parent_sources for the table.
 666
 667
 668 =item add_additional_parents
 669
 670
 671 Continuing with coffee:
 672
 673     __PACKAGE__->result_source_instance->add_additional_parents(
 674         qw/
 675             MyApp::Schema::Result::Beverage
 676             MyApp::Schema::Result::Liquid
 677         /
 678     );
 679
 680 This just lets you manually add additional parents beyond the ones MTI finds.
 681
 682 =item add_additional_parent
 683
 684     __PACKAGE__->result_source_instance->add_additional_parent(
 685             MyApp::Schema::Result::Beverage
 686     );
 687
 688 You can also add just one.
 689
 690 =item attach_additional_sources
 691
 692 MTI takes the parents' sources and relationships, creates a new
 693 DBIx::Class::Table object from them, and registers this as a new, raw, source
 694 in the schema, e.g.,
 695
 696     use MyApp::Schema;
 697
 698     print STDERR map { "$_\n" } MyApp::Schema->sources;
 699
 700     # Coffee
 701     # Beverage
 702     # Liquid
 703     # Sumatra
 704     # Raw::Sumatra
 705
 706 Raw::Sumatra will be used to generate the view.
 707
 708 =item view_definition
 709
 710 This takes the raw table and generates the view (and stored procedures) you will use.
 711
 712 =back
 713
 714 =head1 AUTHOR
 715
 716 Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>
 717
 718 =head2 CONTRIBUTORS
 719
 720 Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>
 721
 722 =head1 COPYRIGHT
 723
 724 Copyright (c) 2010 the DBIx::Class::ResultSource::MultipleTableInheritance
 725 L</AUTHOR> and L</CONTRIBUTORS> as listed above.
 726
 727 =head1 LICENSE
 728
 729 This library is free software; you can redistribute it and/or modify
 730 it under the same terms as Perl itself.
 731
 732 =head1 SEE ALSO
 733
 734 L<DBIx::Class>
 735 L<DBIx::Class::ResultSource>
 736
 737 =cut