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 # how this works:
  15 #
  16 # On construction, we hook $self->result_class->result_source_instance
  17 # if present to get the superclass' source object
  18 #
  19 # When attached to a schema, we need to add sources to that schema with
  20 # appropriate relationships for the foreign keys so the concrete tables
  21 # get generated
  22 #
  23 # We also generate our own view definition using this class' concrete table
  24 # and the view for the superclass, and stored procedures for the insert,
  25 # update and delete operations on this view.
  26 #
  27 # deploying the postgres rules through SQLT may be a pain though.
  28
  29 __PACKAGE__->mk_group_accessors(simple => qw(parent_source));
  30
  31 method new ($class: @args) {
  32   my $new = $class->next::method(@args);
  33   my $rc = $new->result_class;
  34   if (my $meth = $rc->can('result_source_instance')) {
  35     my $source = $rc->$meth;
  36     if ($source->result_class ne $new->result_class
  37         && $new->result_class->isa($source->result_class)) {
  38       $new->parent_source($source);
  39     }
  40   }
  41   return $new;
  42 }
  43
  44 method schema (@args) {
  45   my $ret = $self->next::method(@args);
  46   if (@args) {
  47     $self->_attach_additional_sources;
  48   }
  49   return $ret;
  50 }
  51
  52 method _attach_additional_sources () {
  53   my $raw_name = $self->raw_source_name;
  54   my $schema = $self->schema;
  55
  56   # if the raw source is already present we can assume we're done
  57   return if grep { $_ eq $raw_name } $schema->sources;
  58
  59   # our parent should've been registered already actually due to DBIC
  60   # attaching subclass sources later in load_namespaces
  61
  62   my $parent;
  63   if ($self->parent_source) {
  64       my $parent_name = $self->parent_source->name;
  65     ($parent) =
  66       grep { $_->name eq $parent_name }
  67         map $schema->source($_), $schema->sources;
  68     confess "Couldn't find attached source for parent $parent_name - did you use load_classes? This module is only compatible with load_namespaces"
  69       unless $parent;
  70     $self->parent_source($parent); # so our parent is the one in this schema
  71   }
  72
  73   # create the raw table source
  74
  75   my $table = Table->new({ name => $self->raw_table_name });
  76
  77   # we don't need to add the PK cols explicitly if we're the root table
  78   # since they'll get added below
  79
  80   if ($parent) {
  81     my %join;
  82     foreach my $pri ($self->primary_columns) {
  83       my %info = %{$self->column_info($pri)};
  84       delete @info{qw(is_auto_increment sequence auto_nextval)};
  85       $table->add_column($pri => \%info);
  86       $join{"foreign.${pri}"} = "self.${pri}";
  87     }
  88     # have to use source name lookups rather than result class here
  89     # because we don't actually have a result class on the raw sources
  90     $table->add_relationship('parent', $parent->raw_source_name, \%join);
  91   }
  92
  93   # add every column that's actually a concrete part of us
  94
  95   $table->add_columns(
  96     map { ($_ => { %{$self->column_info($_)} }) }
  97       grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
  98         $self->columns
  99   );
 100   $table->set_primary_key($self->primary_columns);
 101
 102   # we need to copy our rels to the raw object as well
 103   # note that ->add_relationship on a source object doesn't create an
 104   # accessor so we can leave that part in the attributes
 105
 106   # if the other side is a table then we need to copy any rels it has
 107   # back to us, as well, so that they point at the raw table. if the
 108   # other side is an MTI view then we need to create the rels to it to
 109   # point at -its- raw table; we don't need to worry about backrels because
 110   # it's going to run this method too (and its raw source might not exist
 111   # yet so we can't, anyway)
 112
 113   foreach my $rel ($self->relationships) {
 114     my $rel_info = $self->relationship_info($rel);
 115
 116     my $f_source = $schema->source($rel_info->{source});
 117
 118     # __PACKAGE__ is correct here because subclasses should be caught
 119
 120     my $one_of_us = $f_source->isa(__PACKAGE__);
 121
 122     my $f_source_name = $f_source->${\
 123                         ($one_of_us ? 'raw_source_name' : 'source_name')
 124                       };
 125
 126     $table->add_relationship(
 127       '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
 128     );
 129
 130     unless ($one_of_us) {
 131       my $reverse = do {
 132         # we haven't been registered yet, so reverse_ cries
 133         # XXX this is evil and will probably break eventually
 134         local @{$schema->source_registrations}
 135                {map $self->$_, qw(source_name result_class)}
 136           = ($self, $self);
 137         $self->reverse_relationship_info($rel);
 138       };
 139       foreach my $rev_rel (keys %$reverse) {
 140         $f_source->add_relationship(
 141           '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
 142         );
 143       }
 144     }
 145   }
 146
 147   $schema->register_source($raw_name => $table);
 148 }
 149
 150 method set_primary_key (@args) {
 151   if ($self->parent_source) {
 152     confess "Can't set primary key on a subclass";
 153   }
 154   return $self->next::method(@args);
 155 }
 156
 157 method raw_source_name () {
 158   my $base = $self->source_name;
 159   confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
 160     unless $base;
 161   return 'Raw::'.$base;
 162 }
 163
 164 method raw_table_name () {
 165   return '_'.$self->name;
 166 }
 167
 168 method add_columns (@args) {
 169   my $ret = $self->next::method(@args);
 170   $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
 171   return $ret;
 172 }
 173
 174 BEGIN {
 175
 176   # helper routines, constructed as anon subs so autoclean nukes them
 177
 178   use signatures;
 179
 180   *argify = sub (@names) {
 181     map '_'.$_, @names;
 182   };
 183
 184   *qualify_with = sub ($source, @names) {
 185     my $name = blessed($source) ? $source->name : $source;
 186     map join('.', $name, $_), @names;
 187   };
 188
 189   *body_cols = sub ($source) {
 190     my %pk; @pk{$source->primary_columns} = ();
 191     map +{ %{$source->column_info($_)}, name => $_ },
 192       grep !exists $pk{$_}, $source->columns;
 193   };
 194
 195   *pk_cols = sub ($source) {
 196     map +{ %{$source->column_info($_)}, name => $_ },
 197       $source->primary_columns;
 198   };
 199
 200   *names_of = sub (@cols) { map $_->{name}, @cols };
 201
 202   *function_body = sub ($name, $args, $body_parts) {
 203     my $arglist = join(
 204       ', ',
 205         map "_${\$_->{name}} ${\uc($_->{data_type})}",
 206           @$args
 207     );
 208     my $body = join("\n", '', map "          $_;", @$body_parts);
 209     return strip tt q{
 210       CREATE OR REPLACE FUNCTION [% name %]
 211         ([% arglist %])
 212         RETURNS VOID AS $function$
 213         BEGIN
 214           [%- body %]
 215         END;
 216       $function$ LANGUAGE plpgsql;
 217     };
 218   };
 219 }
 220
 221 BEGIN {
 222
 223   use signatures;
 224
 225   *arg_hash = sub ($source) {
 226     map +($_ => \(argify $_)), names_of body_cols $source;
 227   };
 228
 229   *rule_body = sub ($on, $to, $oldlist, $newlist) {
 230     my $arglist = join(', ',
 231       (qualify_with 'OLD', names_of @$oldlist),
 232       (qualify_with 'NEW', names_of @$newlist),
 233     );
 234     $to = $to->name if blessed($to);
 235     return strip tt q{
 236       CREATE RULE _[% to %]_[% on %]_rule AS
 237         ON [% on | upper %] TO [% to %]
 238         DO INSTEAD (
 239           SELECT _[% to %]_[% on %]([% arglist %])
 240         );
 241     };
 242   };
 243 }
 244
 245 method root_table () {
 246   $self->parent_source
 247     ? $self->parent_source->root_table
 248     : $self->schema->source($self->raw_source_name)
 249 }
 250
 251 method view_definition () {
 252   my $schema = $self->schema;
 253   confess "Can't generate view without connected schema, sorry"
 254     unless $schema && $schema->storage;
 255   my $sqla = $schema->storage->sql_maker;
 256   my @sources = my $table = $self->schema->source($self->raw_source_name);
 257   my $super_view = $self->parent_source;
 258   push(@sources, $super_view) if defined($super_view);
 259   my @body_cols = map body_cols($_), @sources;
 260   my @pk_cols = pk_cols $self;
 261
 262   # SELECT statement
 263
 264   my $select = $sqla->select(
 265     ($super_view
 266       ? ([   # FROM _tbl _tbl
 267            { $table->name => $table->name },
 268            [ # JOIN view view
 269              { $super_view->name => $super_view->name },
 270              # ON _tbl.id = view.id
 271              { map +(qualify_with($super_view, $_), qualify_with($table, $_)),
 272                  names_of @pk_cols }
 273            ]
 274          ])
 275       : ($table->name)),
 276     [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
 277   ).';';
 278
 279   my ($now, $next) = grep defined, $super_view, $table;
 280
 281   # INSERT function
 282
 283   # NOTE: this assumes a single PK col called id with a sequence somewhere
 284   # but nothing else -should- so fixing this should make everything work
 285   my $insert_func =
 286     function_body
 287       $self->name.'_insert',
 288       \@body_cols,
 289       [
 290         $sqla->insert( # INSERT INTO _tbl (foo, ...) VALUES (_foo, ...)
 291           $now->name,
 292           { arg_hash $now },
 293         ),
 294         ($next
 295           ? $sqla->insert( # INSERT INTO super_view (id, ...)
 296                            #   VALUES (currval('_root_tbl_id_seq'), ...)
 297               $next->name,
 298               {
 299                 (arg_hash $next),
 300                 id => \"currval('${\$self->root_table->name}_id_seq')",
 301               }
 302             )
 303           : ()
 304         )
 305       ];
 306
 307   # note - similar to arg_hash but not quite enough to share code sanely
 308   my $pk_where = { # id = _id AND id2 = _id2 ...
 309     map +($_ => \"= ${\argify $_}"), names_of @pk_cols
 310   };
 311
 312   # UPDATE function
 313
 314   my $update_func =
 315     function_body
 316       $self->name.'_update',
 317       [ @pk_cols, @body_cols ],
 318       [ map $sqla->update(
 319           $_->name, # UPDATE foo
 320           { arg_hash $_ }, # SET a = _a
 321           $pk_where,
 322         ), @sources
 323       ];
 324
 325   # DELETE function
 326
 327   my $delete_func =
 328     function_body
 329       $self->name.'_delete',
 330       [ @pk_cols ],
 331       [ map $sqla->delete($_->name, $pk_where), @sources ];
 332
 333   my @rules = (
 334     (rule_body insert => $self, [], \@body_cols),
 335     (rule_body update => $self, \@pk_cols, \@body_cols),
 336     (rule_body delete => $self, \@pk_cols, []),
 337   );
 338   return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
 339 }
 340
 341 1;