generate function bodies

[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 namespace::autoclean;

# 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.

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

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 schema (@args) {
  my $ret = $self->next::method(@args);
  if (@args) {
    $self->_attach_additional_sources;
  }
  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

  if ($parent) {
    my %join;
    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);
      $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, \%join);
  }

  # 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);
  $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;
}

BEGIN {

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

  use signatures;

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

  *qualify_with = sub ($source, @names) {
    map join('.', $source->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;
  };

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

  *function_body = sub ($name, $args, $body_parts) {
    my $arglist = join(
      ', ',
        map '_'.join(' ', @{$_}{qw(name 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;
  };
}

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 @sources = my $table = $self->schema->source($self->raw_source_name);
  my $super_view = $self->parent_source;
  push(@sources, $super_view) if defined($super_view);
  my @body_cols = map body_cols($_), @sources;
  my @pk_cols = pk_cols $self;
  my $select = $sqla->select(
    ($super_view
      ? ([   # FROM _tbl _tbl
           { $table->name => $table->name },
           [ # JOIN view view
             { $super_view->name => $super_view->name },
             # ON _tbl.id = view.id
             { map +(qualify_with($super_view, $_), qualify_with($table, $_)),
                 names_of @pk_cols }
           ]
         ])
      : ($table->name)),
    [ (qualify_with $table, names_of @pk_cols), names_of @body_cols ],
  ).';';
  my ($now, $next) = grep defined, $super_view, $table;
  # 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 (foo, ...) VALUES (_foo, ...)
          $now->name,
          { arg_hash $now },
        ),
        ($next
          ? $sqla->insert( # INSERT INTO super_view (id, ...)
                           #   VALUES (currval('_root_tbl_id_seq'), ...)
              $next->name,
              {
                (arg_hash $next),
                id => \"currval('${\$self->root_table->name}_id_seq')",
              }
            )
          : ()
        )
      ];
  # 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
  };
  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
      ];
  my $delete_func =
    function_body
      $self->name.'_delete',
      [ @pk_cols ],
      [ map $sqla->delete($_->name, $pk_where), @sources ];
  return join("\n\n", $select, $insert_func, $update_func, $delete_func);
}

1;