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