Beginning of docs. Making headway. Next is subroutine docs

[dbsrgits/DBIx-Class-ResultSource-MultipleTableInheritance.git] / lib / DBIx / Class / ResultSource / MultipleTableInheritance.pm

package DBIx::Class::ResultSource::MultipleTableInheritance;

use strict;
use warnings;
use parent qw(DBIx::Class::ResultSource::View);
use Method::Signatures::Simple;
use Carp::Clan qw/^DBIx::Class/;
use aliased 'DBIx::Class::ResultSource::Table';
use aliased 'DBIx::Class::ResultClass::HashRefInflator';
use String::TT qw(strip tt);
use Scalar::Util qw(blessed);
use namespace::autoclean;

our $VERSION = 0.01;

__PACKAGE__->mk_group_accessors(simple => qw(parent_source additional_parents));

method new ($class: @args) {
  my $new = $class->next::method(@args);
  my $rc = $new->result_class;
  if (my $meth = $rc->can('result_source_instance')) {
    my $source = $rc->$meth;
    if ($source->result_class ne $new->result_class
        && $new->result_class->isa($source->result_class)) {
      $new->parent_source($source);
    }
  }
  return $new;
}

method add_additional_parents (@classes) {
  foreach my $class (@classes) {
    Class::C3::Componentised->ensure_class_loaded($class);
    $self->add_additional_parent(
      $class->result_source_instance
    );
  }
}

method add_additional_parent ($source) {
  my ($our_pk, $their_pk) = map {
    join('|',sort $_->primary_columns)
  } ($self, $source);

  confess "Can't attach additional parent ${\$source->name} - it has different PKs ($their_pk versus our $our_pk)"
    unless $their_pk eq $our_pk;
  $self->additional_parents([
    @{$self->additional_parents||[]}, $source
  ]);
  $self->add_columns(
    map {
      $_ => # put the extra key first to default it
      { originally_defined_in => $source->name, %{$source->column_info($_)}, },
    } grep !$self->has_column($_), $source->columns
  );
  foreach my $rel ($source->relationships) {
    my $rel_info = $source->relationship_info($rel);
    $self->add_relationship(
      $rel, $rel_info->{source}, $rel_info->{cond},
      # extra key first to default it
      {originally_defined_in => $source->name, %{$rel_info->{attrs}}},
    );
  }
  { no strict 'refs';
    push(@{$self->result_class.'::ISA'}, $source->result_class);
  }
}

method _source_by_name ($name) {
  my $schema = $self->schema;
  my ($source) = 
    grep { $_->name eq $name }
      map $schema->source($_), $schema->sources;
  confess "Couldn't find attached source for parent $name - did you use load_classes? This module is only compatible with load_namespaces"
    unless $source;
  return $source;
}

method schema (@args) {
  my $ret = $self->next::method(@args);
  if (@args) {
    if ($self->parent_source) {
      my $parent_name = $self->parent_source->name;
      $self->parent_source($self->_source_by_name($parent_name));
    }
    $self->additional_parents([
      map { $self->_source_by_name($_->name) }
      @{$self->additional_parents||[]}
    ]);
  }
  return $ret;
}

method attach_additional_sources () {
  my $raw_name = $self->raw_source_name;
  my $schema = $self->schema;

  # if the raw source is already present we can assume we're done
  return if grep { $_ eq $raw_name } $schema->sources;

  # our parent should've been registered already actually due to DBIC
  # attaching subclass sources later in load_namespaces

  my $parent;
  if ($self->parent_source) {
      my $parent_name = $self->parent_source->name;
    ($parent) = 
      grep { $_->name eq $parent_name }
        map $schema->source($_), $schema->sources;
    confess "Couldn't find attached source for parent $parent_name - did you use load_classes? This module is only compatible with load_namespaces"
      unless $parent;
    $self->parent_source($parent); # so our parent is the one in this schema
  }

  # create the raw table source

  my $table = Table->new({ name => $self->raw_table_name });

  # we don't need to add the PK cols explicitly if we're the root table
  # since they'll get added below

  my %pk_join;

  if ($parent) {
    foreach my $pri ($self->primary_columns) {
      my %info = %{$self->column_info($pri)};
      delete @info{qw(is_auto_increment sequence auto_nextval)};
      $table->add_column($pri => \%info);
      $pk_join{"foreign.${pri}"} = "self.${pri}";
    }
    # have to use source name lookups rather than result class here
    # because we don't actually have a result class on the raw sources
    $table->add_relationship('parent', $parent->raw_source_name, \%pk_join);
    $self->depends_on->{$parent->source_name} = 1;
  }

  foreach my $add (@{$self->additional_parents||[]}) {
    $table->add_relationship(
      'parent_'.$add->name, $add->source_name, \%pk_join
    );
    $self->depends_on->{$add->source_name} = 1;
  }

  # add every column that's actually a concrete part of us

  $table->add_columns(
    map { ($_ => { %{$self->column_info($_)} }) }
      grep { $self->column_info($_)->{originally_defined_in} eq $self->name }
        $self->columns
  );
  $table->set_primary_key($self->primary_columns);

  # we need to copy our rels to the raw object as well
  # note that ->add_relationship on a source object doesn't create an
  # accessor so we can leave that part in the attributes

  # if the other side is a table then we need to copy any rels it has
  # back to us, as well, so that they point at the raw table. if the
  # other side is an MTI view then we need to create the rels to it to
  # point at -its- raw table; we don't need to worry about backrels because
  # it's going to run this method too (and its raw source might not exist
  # yet so we can't, anyway)

  foreach my $rel ($self->relationships) {
    my $rel_info = $self->relationship_info($rel);

    # if we got this from the superclass, -its- raw table will nail this.
    # if we got it from an additional parent, it's its problem.
    next unless $rel_info->{attrs}{originally_defined_in} eq $self->name;

    my $f_source = $schema->source($rel_info->{source});

    # __PACKAGE__ is correct here because subclasses should be caught

    my $one_of_us = $f_source->isa(__PACKAGE__);

    my $f_source_name = $f_source->${\
                        ($one_of_us ? 'raw_source_name' : 'source_name')
                      };
    
    $table->add_relationship(
      '_'.$rel, $f_source_name, @{$rel_info}{qw(cond attrs)}
    );

    unless ($one_of_us) {
      my $reverse = do {
        # we haven't been registered yet, so reverse_ cries
        # XXX this is evil and will probably break eventually
        local @{$schema->source_registrations}
               {map $self->$_, qw(source_name result_class)}
          = ($self, $self);
        $self->reverse_relationship_info($rel);
      };
      foreach my $rev_rel (keys %$reverse) {
        $f_source->add_relationship(
          '_raw_'.$rev_rel, $raw_name, @{$reverse->{$rev_rel}}{qw(cond attrs)}
        );
      }
    }
  }

  $schema->register_source($raw_name => $table);
}

method set_primary_key (@args) {
  if ($self->parent_source) {
    confess "Can't set primary key on a subclass";
  }
  return $self->next::method(@args);
}

method raw_source_name () {
  my $base = $self->source_name;
  confess "Can't generate raw source name for ${\$self->name} when we don't have a source_name"
    unless $base;
  return 'Raw::'.$base;
}

method raw_table_name () {
  return '_'.$self->name;
}

method add_columns (@args) {
  my $ret = $self->next::method(@args);
  $_->{originally_defined_in} ||= $self->name for values %{$self->_columns};
  return $ret;
}

method add_relationship ($name, $f_source, $cond, $attrs) {
  $self->next::method(
    $name, $f_source, $cond,
    { originally_defined_in => $self->name, %{$attrs||{}}, }
  );
}

BEGIN {

  # helper routines, constructed as anon subs so autoclean nukes them

  use signatures;

  *argify = sub (@names) {
    map '_'.$_, @names;
  };

  *qualify_with = sub ($source, @names) {
    my $name = blessed($source) ? $source->name : $source;
    map join('.', $name, $_), @names;
  };

  *body_cols = sub ($source) {
    my %pk; @pk{$source->primary_columns} = ();
    map +{ %{$source->column_info($_)}, name => $_ },
      grep !exists $pk{$_}, $source->columns;
  };

  *pk_cols = sub ($source) {
    map +{ %{$source->column_info($_)}, name => $_ },
      $source->primary_columns;
  };

  *names_of = sub (@cols) { map $_->{name}, @cols };

  *function_body = sub ($name, $args, $body_parts) {
    my $arglist = join(
      ', ',
        map "_${\$_->{name}} ${\uc($_->{data_type})}",
          @$args
    );
    my $body = join("\n", '', map "          $_;", @$body_parts);
    return strip tt q{
      CREATE OR REPLACE FUNCTION [% name %]
        ([% arglist %])
        RETURNS VOID AS $function$
        BEGIN
          [%- body %]
        END;
      $function$ LANGUAGE plpgsql;
    };
  };
}

BEGIN {

  use signatures;

  *arg_hash = sub ($source) {
    map +($_ => \(argify $_)), names_of body_cols $source;
  };

  *rule_body = sub ($on, $to, $oldlist, $newlist) {
    my $arglist = join(', ',
      (qualify_with 'OLD', names_of @$oldlist),
      (qualify_with 'NEW', names_of @$newlist),
    );
    $to = $to->name if blessed($to);
    return strip tt q{
      CREATE RULE _[% to %]_[% on %]_rule AS
        ON [% on | upper %] TO [% to %]
        DO INSTEAD (
          SELECT [% to %]_[% on %]([% arglist %])
        );
    };
  };
}

method root_table () {
  $self->parent_source
    ? $self->parent_source->root_table
    : $self->schema->source($self->raw_source_name)
}

method view_definition () {
  my $schema = $self->schema;
  confess "Can't generate view without connected schema, sorry"
    unless $schema && $schema->storage;
  my $sqla = $schema->storage->sql_maker;
  my $table = $self->schema->source($self->raw_source_name);
  my $super_view = $self->parent_source;
  my @all_parents = my @other_parents = @{$self->additional_parents||[]};
  push(@all_parents, $super_view) if defined($super_view);
  my @sources = ($table, @all_parents);
  my @body_cols = map body_cols($_), @sources;
  my @pk_cols = pk_cols $self;

  # SELECT statement

  my $am_root = !($super_view || @other_parents);

  my $select = $sqla->select(
    ($am_root
      ? ($table->name)
      : ([   # FROM _tbl _tbl
           { $table->name => $table->name },
           map {
             my $parent = $_;
             [ # JOIN view view
               { $parent->name => $parent->name },
               # ON _tbl.id = view.id
               { map +(qualify_with($parent, $_), qualify_with($table, $_)),
                   names_of @pk_cols }
             ]
           } @all_parents
         ])
      ),
    [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
  ).';';

  my ($now, @next) = grep defined, $super_view, $table, @other_parents;

  # INSERT function

  # NOTE: this assumes a single PK col called id with a sequence somewhere
  # but nothing else -should- so fixing this should make everything work
  my $insert_func =
    function_body
      $self->name.'_insert',
      \@body_cols,
      [
        $sqla->insert( # INSERT INTO tbl/super_view (foo, ...) VALUES (_foo, ...)
          $now->name,
          { arg_hash $now },
        ),
        (map {
          $sqla->insert( # INSERT INTO parent (id, ...)
                         #   VALUES (currval('_root_tbl_id_seq'), ...)
            $_->name,
            {
              (arg_hash $_),
              id => \"currval('${\$self->root_table->name}_id_seq')",
            }
          )
        } @next)
      ];

  # note - similar to arg_hash but not quite enough to share code sanely
  my $pk_where = { # id = _id AND id2 = _id2 ...
    map +($_ => \"= ${\argify $_}"), names_of @pk_cols
  };

  # UPDATE function

  my $update_func =
    function_body
      $self->name.'_update',
      [ @pk_cols, @body_cols ],
      [ map $sqla->update(
          $_->name, # UPDATE foo
          { arg_hash $_ }, # SET a = _a
          $pk_where,
        ), @sources
      ];

  # DELETE function

  my $delete_func =
    function_body
      $self->name.'_delete',
      [ @pk_cols ],
      [ map $sqla->delete($_->name, $pk_where), @sources ];

  my @rules = (
    (rule_body insert => $self, [], \@body_cols),
    (rule_body update => $self, \@pk_cols, \@body_cols),
    (rule_body delete => $self, \@pk_cols, []),
  );
  return join("\n\n", $select, $insert_func, $update_func, $delete_func, @rules);
}

1;

__END__

# how this works:
#
# On construction, we hook $self->result_class->result_source_instance
# if present to get the superclass' source object
# 
# When attached to a schema, we need to add sources to that schema with
# appropriate relationships for the foreign keys so the concrete tables
# get generated
#
# We also generate our own view definition using this class' concrete table
# and the view for the superclass, and stored procedures for the insert,
# update and delete operations on this view.
#
# deploying the postgres rules through SQLT may be a pain though.

=encoding utf-8

=head1 NAME

DBIx::Class::ResultSource::MultipleTableInheritance -- Use multiple tables to define your classes 

=head1 SYNOPSIS


    {
        package MyApp::Schema::Result::Coffee;

        __PACKAGE__->table_class('DBIx::Class::ResultSource::MultipleTableInheritance');
        __PACKAGE__->table('coffee');
        __PACKAGE__->add_columns(
          "id",
          {
            data_type => "integer",
            default_value => "nextval('coffee_seq'::regclass)",
            is_auto_increment => 1,
            is_foreign_key => 1,
            is_nullable => 0,
            size => 4,
          },
          "flavor",
          {
            data_type => "text",
            default_value => "good",
          },
        );

        __PACKAGE__->set_primary_key("id");

        1;
    }

    {
        package MyApp::Schema::Result::Sumatra;

        use parent 'Coffee';

        __PACKAGE__->table('sumatra');

        __PACKAGE__->add_columns(
          "aroma",
          {
            data_type => "text",
            default_value => undef,
            is_nullable => 0,
          },
        );

        1;
    }
    
    ...

    my $schema = MyApp::Schema->connect($dsn);

    my $cup = $schema->resultset('Sumatra')->new;

    print STDERR Dumper $cup->columns;

        $VAR1 = 'id';
        $VAR2 = 'flavor';
        $VAR3 = 'aroma';



Inherit from this package and you can make a resultset class from a view, but that's more than a little bit misleading: the result is B<transparentlt writable>.

This is accomplished through the use of stored functions that map changes written to the view to changes to the underlying concrete tables.

=head1 WHY?

In many applications, many classes are subclasses of others. Let's say you have this schema:

    # Conceptual domain model
    
    class User {
            has id,
            has name,
            has password
    }

    class Investor {
        has id,
        has name,
        has password,
        has dollars
    }

That's redundant. Hold on a sec...

    class User {
            has id,
            has name,
            has password
    }

    class Investor isa User {
        has dollars
    }

Good idea, but how to put this into code?

One far-too common and absolutely horrendous solution is to have a "checkbox" in your database: a nullable "investor" column, which entails a nullable "dollars" column, in the user table.

    create table "user" (
        "id" integer not null primary key autoincrement,
        "name" text not null,
        "password" text not null,
        "investor" tinyint(1),
        "dollars" integer
    );

Let's not discuss that further.

A second, better, solution is to break out the two tables into user and investor:

    create table "user" (
        "id" integer not null primary key autoincrement,
        "name" text not null,
        "password" text not null
    );
        
    create table "investor" (
        "id" integer not null references user("id"),
        "dollars" integer
    );

So that investor's PK is just an FK to the user. We can clearly see the class hierarchy here, in which investor is a subclass of user. In DBIx::Class applications, this second strategy looks like:
    
    my $user_rs = $schema->resultset('User');
    my $new_user = $user_rs->create(
        name => $args->{name},
        password => $args->{password},
    );

    ...

    my $new_investor = $schema->resultset('Investor')->create(
        id => $new_user->id,
        dollars => $args->{dollars},
    );

One can cope well with the second strategy, and it seems to be the most popular smart choice.

=head1 HOW?

There is a third strategy implemented here. Make the database do more of the work. It'll save us some typing and it'll make for more expressive code. What if we could do this:

    my $new_investor = $schema->resultset('Investor')->create(
        name => $args->{name},
        password => $args->{password},
        dollars => $args->{dollars},
    );
    
And have it Just Work? The user ( {name => $args->{name}, password => $args->{password} } ) should be created transparently, and the use of either user or investor in your code should require no special handling. Deleting and updating $new_investor should also delete or update the user row.

It does. User and investor are both views, their concrete tables abstracted away behind a set of rules and triggers. You would expect the above DBIC create statement to look like this in SQL:

    INSERT INTO investor ("name","password","dollars") VALUES (...);

But using MTI, it is really this:

    INSERT INTO _user_table ("username","password") VALUES (...);
    INSERT INTO _investor_table ("id","dollars") VALUES (currval('_user_table_id_seq',...) );

For deletes, the triggers fire in reverse, to preserve referential integrity (foreign key constraints). For instance:

   my $investor = $schema->resultset('Investor')->find({id => $args->{id}});
   $investor->delete;

Becomes:

    DELETE FROM _investor_table WHERE ("id" = ?);
    DELETE FROM _user_table WHERE ("id" = ?);


    





=head1 AUTHOR

Matt S. Trout, E<lt>mst@shadowcatsystems.co.ukE<gt>

=head2 CONTRIBUTORS

Docs: Amiri Barksdale, E<lt>amiri@metalabel.comE<gt>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<DBIx::Class>
L<DBIx::Class::ResultSource>

=cut