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