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