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