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