File Coverage

blib/lib/Evo/Class/Meta.pm

Criterion	Covered	Total	%
statement	289	289	100.0
branch	111	174	63.7
condition	27	28	96.4
subroutine	41	41	100.0
pod	7	25	28.0
total	475	557	85.2

package Evo::Class::Meta;
use Evo 'Carp croak; Scalar::Util reftype; -Internal::Util; Module::Load ()';
use Evo '/::Attrs *; /::Syntax *';

our @CARP_NOT = qw(Evo::Class);

sub register ($me, $package) {
  no strict 'refs';    ## no critic
  no warnings 'once';

  ${"${package}::EVO_CLASS_ATTRS"} ||= Evo::Class::Attrs->new;

  ${"${package}::EVO_CLASS_META"}
    ||= bless {package => $package, private => {}, methods => {}, reqs => {}, overridden => {}},
    $me;
}

sub find_or_croak ($self, $package) {
  no strict 'refs';    ## no critic
  ${"${package}::EVO_CLASS_META"}
    or croak qq#$package isn't Evo::Class; "use parent '$package';" for external classes#;
}

sub package($self) { $self->{package} }

sub attrs($self) {
  no strict 'refs';    ## no critic
  my $package = $self->{package};
  ${"${package}::EVO_CLASS_ATTRS"};
}

sub methods($self) { $self->{methods} }
sub reqs($self)    { $self->{reqs} }

sub overridden($self) { $self->{overridden} }
sub private($self)    { $self->{private} }

sub mark_as_overridden ($self, $name) {
  $self->overridden->{$name} = 1;
  $self;
}

sub is_overridden ($self, $name) {
  $self->overridden->{$name};
}

sub mark_as_private ($self, $name) {
  $self->private->{$name} = 1;
}

sub is_private ($self, $name) {
  $self->private->{$name};
}

# first check methods (marked as method or inherited), if doesn't exists, try to determine if there is a sub in package
# if a sub is compiled in the same package, it's a public, if not(imported or xsub), and not exported function - it's private

sub is_method ($self, $name) {
  return 1 if $self->methods->{$name};
  my $pkg = $self->package;

  {
    no strict 'refs';    ## no critic
    no warnings 'once';
    my $meta = ${"${pkg}::EVO_EXPORT_META"};
    return if $meta && $meta->symbols->{$name};
  }

  my $code = Evo::Internal::Util::names2code($pkg, $name) or return;
  my ($realpkg, $realname, $xsub) = Evo::Internal::Util::code2names($code);
  return !$xsub && $realpkg eq $pkg;
}

sub is_attr ($self, $name) {
  $self->attrs->exists($name);
}

sub _check_valid_name ($self, $name) {
  croak(qq{"$name" is invalid name}) unless Evo::Internal::Util::check_subname($name);
}

sub _check_exists ($self, $name) {
  my $pkg = $self->package;
  croak qq{$pkg already has attribute "$name"} if $self->is_attr($name);
  croak qq{$pkg already has method "$name"}    if $self->is_method($name);
}

sub _check_exists_valid_name ($self, $name) {
  _check_valid_name($self, $name);
  _check_exists($self, $name);
}

sub _reg_parsed_attr ($self, %opts) {
  my $name = $opts{name};
  _check_exists_valid_name($self, $name);
  my $pkg = $self->package;
  croak qq{$pkg already has subroutine "$name"} if Evo::Internal::Util::names2code($pkg, $name);

  my $sub = $self->attrs->gen_attr(%opts);    # register
  Evo::Internal::Util::monkey_patch $pkg, $name, $sub if $opts{method};
}

sub _reg_parsed_attr_over ($self, %opts) {
  my $name = $opts{name};
  _check_valid_name($self, $name);
  $self->mark_as_overridden($name);
  my $sub = $self->attrs->gen_attr(%opts);    # register
  my $pkg = $self->package;
  Evo::Internal::Util::monkey_patch_silent $pkg, $name, $sub if $opts{method};
}

sub reg_attr ($self, $name, @attr) {
  my %opts = $self->parse_attr($name, @attr);
  $self->_reg_parsed_attr(%opts);
}

sub reg_attr_over ($self, $name, @attr) {
  my %opts = $self->parse_attr($name, @attr);
  $self->_reg_parsed_attr_over(%opts);
}

# means register external sub as method. Because every sub in the current package
# is public by default
sub reg_method ($self, $name) {
  _check_exists_valid_name($self, $name);
  my $pkg = $self->package;
  my $code = Evo::Internal::Util::names2code($pkg, $name) or croak "$pkg::$name doesn't exist";
  $self->methods->{$name}++;
}

sub _public_attrs_slots($self) {
  grep { !$self->is_private($_->{name}) } $self->attrs->slots;
}

# not marked as private
# was compiled in the same package, not constant, not exported lib
sub _public_methods_map($self) {
  my $pkg = $self->package;
  map { ($_, Evo::Internal::Util::names2code($pkg, $_)) }
    grep { !$self->is_private($_) && $self->is_method($_) }
    Evo::Internal::Util::list_symbols($pkg);
}

sub public_attrs($self) {
  map { $_->{name} } $self->_public_attrs_slots;
}

sub public_methods($self) {
  my %map = $self->_public_methods_map;
  keys %map;
}


sub extend_with ($self, $source_p) {
  $source_p = Evo::Internal::Util::resolve_package($self->package, $source_p);
  Module::Load::load($source_p);
  my $source  = $self->find_or_croak($source_p);
  my $dest_p  = $self->package;
  my %reqs    = $source->reqs()->%*;
  my %methods = $source->_public_methods_map();

  my @new_attrs;
  foreach my $name (keys %reqs) { $self->reg_requirement($name); }

  foreach my $slot ($source->_public_attrs_slots) {
    next if $self->is_overridden($slot->{name});
    $self->_reg_parsed_attr(%$slot);
    push @new_attrs, $slot->{name};
  }

  foreach my $name (keys %methods) {
    next if $self->is_overridden($name);
    croak qq/$dest_p already has a subroutine with name "$name"/
      if Evo::Internal::Util::names2code($dest_p, $name);
    _check_exists($self, $name);    # prevent patching before check
    Evo::Internal::Util::monkey_patch $dest_p, $name, $methods{$name};
    $self->reg_method($name);
  }

  no strict 'refs';                 ## no critic
  push @{"${dest_p}::ISA"}, $source_p;
  @new_attrs;
}


sub reg_requirement ($self, $name) {
  $self->reqs->{$name}++;
}

sub requirements($self) {
  (keys($self->reqs->%*), $self->public_attrs, $self->public_methods);
}

sub check_implementation ($self, $inter_class) {
  $inter_class = Evo::Internal::Util::resolve_package($self->package, $inter_class);
  Module::Load::load($inter_class);
  my $class = $self->package;
  my $inter = $self->find_or_croak($inter_class);
  my @reqs  = sort $inter->requirements;

  my @not_exists = grep { !($self->is_attr($_) || $class->can($_)); } @reqs;
  return $self if !@not_exists;

  croak qq/Bad implementation of "$inter_class", missing in "$class": /, join ';', @not_exists;
}

# -- class methods for usage from other modules too


# rtype: default, default_code, required, lazy, relaxed
# rvalue is used as meta for required(di), default and lazy
# check?
# is_ro?

sub parse_attr ($me, $name, @attr) {
  my @scalars = grep { $_ ne SYNTAX_STATE } @attr;
  croak "expected 1 scalar, got: " . join ',', @scalars if @scalars > 1;
  my %state = syntax_reset;

  croak qq#"optional" flag makes no sense with default("$scalars[0]")#
    if $state{optional} && @scalars;
  croak qq#"lazy" requires code reference#
    if $state{lazy} && (reftype($scalars[0]) // '') ne 'CODE';
  croak qq#default("$scalars[0]") should be either a scalar or a code reference#
    if @scalars && ref($scalars[0]) && reftype($scalars[0]) ne 'CODE';


  my $type;
  if    ($state{optional}) { $type = ECA_OPTIONAL if $state{optional}; }
  elsif ($state{lazy})     { $type = ECA_LAZY     if $state{lazy}; }
  elsif (@scalars) { $type = ref($scalars[0]) ? ECA_DEFAULT_CODE : ECA_DEFAULT; }
  else             { $type = ECA_REQUIRED; }

  return (
    name   => $name,
    type   => $type,
    value  => $scalars[0],
    check  => $state{check},
    ro     => !!$state{ro},
    inject => $state{inject},
    method => !$state{no_method},
  );
}

sub info($self) {
  my %info = (
    public => {
      methods => [sort $self->public_methods],
      attrs   => [sort $self->public_attrs],
      reqs    => [sort keys($self->reqs->%*)],
    },
    overridden => [sort keys($self->overridden->%*)],
    private    => [sort keys($self->private->%*)],
  );
  \%info;
}


1;

__END__