view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Meta/Association.pm  view on Meta::CPAN

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