File Coverage

blib/lib/DBIx/DataModel/Meta/Association.pm

Criterion	Covered	Total	%
statement	117	119	98.3
branch	33	48	68.7
condition	13	33	39.3
subroutine	20	20	100.0
pod	1	1	100.0
total	184	221	83.2

package DBIx::DataModel::Meta::Association;
use strict;
use warnings;
use parent "DBIx::DataModel::Meta";
use DBIx::DataModel;
use DBIx::DataModel::Meta::Utils qw/define_method define_readonly_accessors/;
use DBIx::DataModel::Carp;
# use Carp::Clan qw(^(DBIx::DataModel|SQL::Abstract));



use Params::Validate qw/validate_with SCALAR ARRAYREF HASHREF OBJECT UNDEF/;
use List::MoreUtils  qw/pairwise/;
use Scalar::Util     qw/weaken dualvar looks_like_number/;
use Module::Load     qw/load/;
use POSIX            qw/LONG_MAX/;
use namespace::clean;


# specification for parameters to new()
my $association_spec = {
  schema => {type => OBJECT, isa  => "DBIx::DataModel::Meta::Schema"},
  A      => {type => HASHREF},
  B      => {type => HASHREF},
  name   => {type => SCALAR, optional => 1}, # computed if absent
  kind   => {type => SCALAR,
             regex => qr/^(Association|Aggregation|Composition)$/},
};

# specification for sub-parameters 'A' and 'B'
my $association_end_spec = {
  table        => {type => OBJECT,
                   isa  => 'DBIx::DataModel::Meta::Source::Table'},
  role         => {type => SCALAR|UNDEF, optional => 1},
  multiplicity => {type => SCALAR|ARRAYREF},    # if scalar : "$min..$max"
  join_cols    => {type => ARRAYREF,     optional => 1},
};

#----------------------------------------------------------------------
# PUBLIC METHODS
#----------------------------------------------------------------------

sub new {
  my $class = shift;

  my $self = validate_with(
    params      => \@_,
    spec        => $association_spec,
    allow_extra => 0,
   );

  # work on both association ends (A and  B)
  for my $letter (qw/A B/) {
    # parse parameters for this association end
    my @letter_params = %{$self->{$letter}};
    my $assoc_end = validate_with(
      params      => \@letter_params,
      spec        => $association_end_spec,
      allow_extra => 0,
     );

    croak "join_cols is present but empty"
      if $assoc_end->{join_cols} && !@{$assoc_end->{join_cols}};

    # transform multiplicity scalar into a pair [$min, $max]
    $class->_parse_multiplicity($assoc_end);

    $self->{$letter} = $assoc_end;
  }

  # set default association name
  my @names = map {$self->{$_}{role} || $self->{$_}{table}{name}} qw/A B/;
  $self->{name} ||= join "_", @names;

  # if many-to-many, needs special treatment
  my $install_method;
  if ($self->{A}{multiplicity}[1] > 1 && $self->{B}{multiplicity}[1] > 1) {
    $install_method = '_install_many_to_many';
  }

  # otherwise, treat as a regular association
  else {
    $install_method = '_install_path';

    # handle implicit column names
    if ($self->{A}{multiplicity}[1] > 1) { # n-to-1
      $self->{B}{join_cols} ||= $self->{B}{table}{primary_key};
      $self->{A}{join_cols} ||= $self->{B}{join_cols};
    }
    elsif ($self->{B}{multiplicity}[1] > 1) { # 1-to-n
      $self->{A}{join_cols} ||= $self->{A}{table}{primary_key};
      $self->{B}{join_cols} ||= $self->{A}{join_cols};
    }

    # check if we have the same number of columns on both sides
    @{$self->{A}{join_cols}} == @{$self->{B}{join_cols}}
      or croak "Association: numbers of columns do not match";
  }

  # instantiate
  bless $self, $class;

  # special checks for compositions
  $self->_check_composition if $self->{kind} eq 'Composition';

  # install methods from A to B and B to A, if role names are not empty
  $self->{A}{role} || $self->{B}{role}
    or croak "at least one side of the association must have a role name";
  $self->$install_method(qw/A B/) if $self->{B}{role};
  $self->$install_method(qw/B A/) if $self->{A}{role};

  # EXPERIMENTAL : no longer need association ends; all info is stored in Paths
  delete@{$self}{qw/A B/};

  # avoid circular reference
  weaken $self->{schema};

  return $self;
}


# accessor methods
define_readonly_accessors(__PACKAGE__, qw/schema name kind path_AB path_BA/);


#----------------------------------------------------------------------
# PRIVATE UTILITY METHODS
#----------------------------------------------------------------------

sub _parse_multiplicity {
  my ($class, $assoc_end) = @_;

  # nothing to do if already an arrayref
  return if ref $assoc_end->{multiplicity};

  # otherwise, parse the scalar
  $assoc_end->{multiplicity} =~ /^(?:             # optional part
                                     (\d+)        #   minimum
                                     \s*\.\.\s*   #   followed by ".."
                                   )?             # end of optional part
                                   (\d+|\*|n)     # maximum
                                   $/x
    or croak "illegal multiplicity : $assoc_end->{multiplicity}";

  # multiplicity '*' is a shortcut for '0..*', and
  # multiplicity '1' is a shortcut for '1..1'.
  my $max_is_star = !looks_like_number($2);
  my $min = defined $1   ? $1             : ($max_is_star ? 0 : $2);
  my $max = $max_is_star ? dualvar(POSIX::LONG_MAX, '*') : $2;
  $assoc_end->{multiplicity} = [$min, $max];
}


sub _install_many_to_many {
  my ($self, $from, $to) = @_;

  # path must contain exactly 2 items (intermediate table + remote table)
  my $role = $self->{$to}{role};
  my @path = @{$self->{$to}{join_cols}};
  @path == 2
    or croak "many-to-many : should have exactly 2 roles";

  # define the method
  $self->{$from}{table}->define_navigation_method($role, @path);
}


sub _install_path {
  my ($self, $from, $to) = @_;

  # build the "ON" condition for SQL::Abstract::More
  my $from_cols = $self->{$from}{join_cols};
  my $to_cols   = $self->{$to}  {join_cols};
  my %condition = pairwise {$a => $b} @$from_cols, @$to_cols;

  # define path
  my $path_metaclass = $self->{schema}{path_metaclass};
  load $path_metaclass;
  my $path_name = $self->{$to}{role};
  $self->{"path_$from$to"} = $path_metaclass->new(
    name         => $path_name,
    from         => $self->{$from}{table},
    to           => $self->{$to}{table},
    on           => \%condition,
    multiplicity => $self->{$to}{multiplicity},
    association  => $self,
    direction    => "$from$to",
   );

  # if 1-to-many, define insertion method
  if ($self->{$to}{multiplicity}[1] > 1) {

    # build method parts
    my $method_name   = "insert_into_$path_name";
    my $to_table_name = $self->{$to}{table}{name};
    my $method_body = sub {
      my $source = shift; # remaining @_ contains refs to records for insert()
      ref($source) or croak "$method_name cannot be called as class method";

      # add join information into records that will be inserted
      foreach my $record (@_) {

        # if this is a scalar, it's no longer a record, but an arg to insert()
        last if !ref $record; # since args are at the end, we exit the loop

        # check that we won't overwrite existing data
	not (grep {exists $record->{$_}} @$to_cols) or
	  croak "args to $method_name should not contain values in @$to_cols";

        # shallow copy and insert values for the join
        $record = {%$record};
	@{$record}{@$to_cols} = @{$source}{@$from_cols};
      }

      return $source->schema->table($to_table_name)->insert(@_);
    };

    # define the method
    define_method(
      class => $self->{$from}{table}{class},
      name  => $method_name,
      body  => $method_body,
     );
  }
}

sub _check_composition {
  my $self = shift;

  # multiplicities must be 1-to-n
  my $msg = "Composition([$self->{A}{table}{name} ..], [$self->{B}{table}{name} ..])";
  $self->_multiplicity_is_exactly_1('A')
    or croak "$msg: $self->{A}{table}{name} must have multiplicity 1..1";
  ! $self->_multiplicity_is_exactly_1('B')
    or croak "$msg: $self->{B}{table}{name} must not have multiplicity 1..1";

  # check for conflicting compositions
  while (my ($name, $path) = each %{$self->{B}{table}{path} || {}}) {
    if ($path->association->kind eq 'Composition' && $path->direction eq 'BA'
        && ($path->multiplicity)[0] > 0) {
      croak "$self->{B}{table}{name} can't be a component "
          . "of $self->{A}{table}{name} "
          . "(already component of $path->{to}{name})";
    }
  }
}

sub _multiplicity_is_exactly_1 {
  my ($self, $end) = @_;
  my $mult = $self->{$end}{multiplicity};

  return $mult->[0] == 1 && $mult->[1] == 1;
}



1;

__END__