view release on metacpan or  search on metacpan

lib/DBIO/Storage/Composed.pm  view on Meta::CPAN

sub compose {
  my ($class, $base, $layers) = @_;
  $layers ||= [];
  my @layers = @$layers;

  return $base unless @layers;

  my $pkg = 'DBIO::Storage::Composed::'
    . join('__', map { (my $s = $_) =~ s/::/_/g; $s } @layers, $base);

  return $pkg if $COMPOSED{$pkg};

  Class::C3::Componentised->ensure_class_loaded($base);
  Class::C3::Componentised->ensure_class_loaded($_) for @layers;

  $class->_assert_no_layer_collisions(\@layers);

  {
    no strict 'refs';
    @{"${pkg}::ISA"} = (@layers, $base);
  }
  mro::set_mro($pkg, 'c3');

  $COMPOSED{$pkg} = { base => $base, layers => [@layers] };

  return $pkg;
}


sub composition_of {
  my ($class, $pkg) = @_;
  return undef unless defined $pkg;
  return $COMPOSED{$pkg};
}


sub layers_of {
  my ($class, $pkg) = @_;
  my $entry = $class->composition_of($pkg) or return;
  return @{ $entry->{layers} };
}


sub recompose {
  my ($class, $pkg, $new_base) = @_;
  my $entry = $class->composition_of($pkg)
    or DBIO::Exception->throw(
      "recompose: '$pkg' is not a composed storage class"
    );
  return $class->compose($new_base, $entry->{layers});
}

# The method names a package defines IN ITSELF -- CODE slots whose compiled body
# actually originates in $pkg, not aliased/imported subs and not inherited ones.
# Standard phasers and OO plumbing are never "layer methods" for collision
# purposes, so they are excluded (two layers each having a BEGIN block, or an
# imported croak, is not a method collision).
my %NOT_A_METHOD = map { $_ => 1 }
  qw(BEGIN END INIT CHECK UNITCHECK DESTROY AUTOLOAD import unimport);

sub _own_methods {
  my ($class, $pkg) = @_;

  my @names;
  no strict 'refs';
  my $stash = \%{"${pkg}::"};
  for my $name (keys %$stash) {
    next if $name =~ /::\z/;          # nested stash, not a sub
    next if $NOT_A_METHOD{$name};
    my $code = *{"${pkg}::${name}"}{CODE};
    next unless defined $code;
    # Only count a sub whose compiled body originates in $pkg -- skips imports
    # and re-exports that merely alias into the stash.
    my $origin = B::svref_2object($code)->GV->STASH->NAME;
    next unless $origin eq $pkg;
    push @names, $name;
  }
  return @names;
}

sub _assert_no_layer_collisions {
  my ($class, $layers) = @_;

  my %defined_in;   # method name => [ packages that define it ]
  for my $layer (@$layers) {
    push @{ $defined_in{$_} }, $layer for $class->_own_methods($layer);
  }

  my @collisions = grep { @{ $defined_in{$_} } > 1 } sort keys %defined_in;
  return unless @collisions;

  my $detail = join '; ', map {
    "$_ (defined in " . join(', ', @{ $defined_in{$_} }) . ')'
  } @collisions;

  DBIO::Exception->throw(
    "storage layer method collision: $detail -- two or more storage layers "
  . 'define the same method; rename or merge them so only one layer owns it, '
  . 'or override the base method in a single layer and let the others chain '
  . 'via next::method'
  );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBIO::Storage::Composed - Runtime C3 composition of storage extension layers over a base storage class

=head1 VERSION

version 0.900002