view release on metacpan or  search on metacpan

lib/DBIO/PopulateMore.pm  view on Meta::CPAN

package DBIO::PopulateMore;

# ABSTRACT: Enhanced populate with cross-source references

use strict;
use warnings;

use Scalar::Util qw(refaddr weaken);
use namespace::clean;


my $MATCH_CONDITION = qr/^!(\w+:.+)$/;


sub populate_more {
  my ($self, $arg, @rest) = @_;

  $self->throw_exception("Argument is required.")
    unless $arg;

  my @args = (ref $arg && ref $arg eq 'ARRAY') ? @$arg : ($arg, @rest);

  my @definitions;
  while (@args) {
    my $next = shift @args;
    if (ref $next && ref $next eq 'HASH') {
      push @definitions, $next;
    } else {
      my $value = shift @args;
      push @definitions, { $next => $value };
    }
  }

  my %rs_index;
  my %seen;
  weaken(my $weak_self = $self);

  my $visit;
  my $dispatch;

  # Visitor: recursively walk data structures, inflating !-prefixed values
  $visit = sub {
    my ($target) = @_;
    if (ref $target eq 'ARRAY') {
      my $addr = refaddr $target;
      return $seen{$addr} if defined $seen{$addr};
      my $new = $seen{$addr} = [];
      @$new = map { $visit->($_) } @$target;
      return $new;
    } elsif (ref $target eq 'HASH') {
      my $addr = refaddr $target;
      return $seen{$addr} if defined $seen{$addr};
      my $new = $seen{$addr} = {};
      %$new = map { $_ => $visit->($target->{$_}) } keys %$target;
      return $new;
    } elsif (defined $target && $target =~ $MATCH_CONDITION) {
      return $dispatch->($1);
    } else {
      return $target;
    }
  };

  # Dispatcher: route !Name:args to the correct inflator
  $dispatch = sub {
    my ($arg) = @_;
    my ($name, $command) = ($arg =~ /^(\w+):(\S.*)$/);

    if ($name eq 'Index') {
      return $rs_index{$command}
        || $weak_self->throw_exception("Bad Index in fixture: $command");
    } elsif ($name eq 'Env') {
      return $ENV{$command}
        // $ENV{uc $command}
        // $weak_self->throw_exception("No match for $command in \%ENV");
    } elsif ($name eq 'Find') {
      my ($source, $id) = split(/\./, $command, 2);
      my $rs = $weak_self->resultset($source)
        or $weak_self->throw_exception("Can't find resultset for $source");
      if ($id =~ /^\[(.+)\]$/) {
        my %keys = map { split(/=/, $_, 2) } split(/,/, $1);
        $id = \%keys;
      }
      return $rs->find($id)
        || $weak_self->throw_exception("Can't find result for '$id' in '$source'");
    } else {
      $weak_self->throw_exception("Unknown inflator: $name");
    }
  };

  for my $definition (@definitions) {
    my ($source, $info) = %$definition;
    my @fields = ref $info->{fields} eq 'ARRAY'
      ? @{$info->{fields}}
      : ($info->{fields});

    my $data = $visit->($info->{data});