File Coverage

blib/lib/Minions.pm

Criterion	Covered	Total	%
statement	350	398	87.9
branch	115	156	73.7
condition	40	57	70.1
subroutine	68	79	86.0
pod	1	2	50.0
total	574	692	82.9

package Minions;

use strict;
use 5.008_005;
use Carp;
use Hash::Util qw( lock_keys );
use List::MoreUtils qw( all );
use Module::Runtime qw( require_module );
use Params::Validate qw(:all);
use Package::Stash;
use Sub::Name;

use Exception::Class (
    'Minions::Error::AssertionFailure' => { alias => 'assert_failed' },
    'Minions::Error::InterfaceMismatch',
    'Minions::Error::MethodDeclaration',
    'Minions::Error::RoleConflict',
);
use Minions::_Guts;

our $VERSION = '1.000001';
$VERSION = eval $VERSION;

my $Class_count = 0;
my %Bound_implementation_of;
my %Interface_for;
my %Util_class;

sub import {
    my ($class, %arg) = @_;

    if ( my $bindings = $arg{bind} ) {

        foreach my $class ( keys %$bindings ) {
            $Bound_implementation_of{$class} = $bindings->{$class};
        }
    }
    elsif ( my $methods = $arg{declare_interface} ) {
        my $caller_pkg = (caller)[0];
        $Interface_for{$caller_pkg} = $methods;
    }
    else {
        $class->minionize(\%arg);
    }
}

sub minionize {
    my (undef, $spec) = @_;

    my $cls_stash;
    if ( ! $spec->{name} ) {
        my $caller_pkg = (caller)[0];

        if ( $caller_pkg eq __PACKAGE__ ) {
            $caller_pkg = (caller 1)[0];
        }
        $cls_stash = Package::Stash->new($caller_pkg);
        $spec = { %$spec, %{ $cls_stash->get_symbol('%__meta__') || {} } };
        $spec->{name} = $caller_pkg;
    }
    $spec->{name} ||= "Minions::Class_${\ ++$Class_count }";

    my @args = %$spec;
    validate(@args, {
        interface => { type => ARRAYREF | SCALAR },
        implementation => { type => SCALAR | HASHREF },
        construct_with => { type => HASHREF, optional => 1 },
        class_methods  => { type => HASHREF, optional => 1 },
        build_args     => { type => CODEREF, optional => 1 },
        name => { type => SCALAR, optional => 1 },
        no_attribute_vars => { type => BOOLEAN, optional => 1 },
    });
    $cls_stash    ||= Package::Stash->new($spec->{name});

    my $obj_stash;

    if ( ! ref $spec->{implementation} ) {
        my $pkg = $Bound_implementation_of{ $spec->{name} } || $spec->{implementation};
        $pkg ne $spec->{name}
          or confess "$spec->{name} cannot be its own implementation.";
        my $stash = _get_stash($pkg);

        my $meta = $stash->get_symbol('%__meta__');
        $spec->{implementation} = {
            package => $pkg,
            methods => $stash->get_all_symbols('CODE'),
            has     => {
                %{ $meta->{has} || { } },
            },
        };
        $spec->{roles} = $meta->{roles};
        $spec->{traitlibs} = $meta->{traitlibs};
        my $is_semiprivate = _interface($meta, 'semiprivate');

        foreach my $sub ( keys %{ $spec->{implementation}{methods} } ) {
            if ( $is_semiprivate->{$sub} ) {
                $spec->{implementation}{semiprivate}{$sub} = delete $spec->{implementation}{methods}{$sub};
            }
        }
    }
    $obj_stash = Package::Stash->new("$spec->{name}::__Minions");

    _prep_interface($spec);
    _compose_roles($spec);
    _compose_traitlibs($spec);

    my $private_stash = Package::Stash->new("$spec->{name}::__Private");
    $cls_stash->add_symbol('$__Obj_pkg', $obj_stash->name);
    $cls_stash->add_symbol('$__Private_pkg', $private_stash->name);
    $cls_stash->add_symbol('%__meta__', $spec) if @_ > 0;

    _make_util_class($spec);
    _add_class_methods($spec, $cls_stash);
    _add_methods($spec, $obj_stash, $private_stash);
    _check_role_requirements($spec);
    _check_traitlib_requirements($spec);
    _check_interface($spec);
    return $spec->{name};
}

sub utility_class {
    my ($class) = @_;

    return $Util_class{ $class }
      or confess "Unknown class: $class";
}

sub _prep_interface {
    my ($spec) = @_;

    return if ref $spec->{interface};
    my $count = 0;
    {

        if (my $methods = $Interface_for{ $spec->{interface} }) {
            $spec->{interface_name} = $spec->{interface};
            $spec->{interface} = $methods;
        }
        else {
            $count > 0
              and confess "Invalid interface: $spec->{interface}";
            require_module($spec->{interface});
            $count++;
            redo;
        }
    }
}

sub _compose_roles {
    my ($spec, $roles, $from_role) = @_;

    if ( ! $roles ) {
        $roles = $spec->{roles};
    }

    $from_role ||= {};

    for my $role ( @{ $roles } ) {

        if ( $spec->{composed_role}{$role} ) {
            confess "Cannot compose role '$role' twice";
        }
        else {
            $spec->{composed_role}{$role}++;
        }

        my ($meta, $method) = _load_role($role);
        $spec->{required_by_role}{$role} = $meta->{requires};
        _compose_roles($spec, $meta->{roles} || [], $from_role);

        _add_role_items($spec, $from_role, $role, $meta->{has}, 'has');
        _add_role_methods($spec, $from_role, $role, $meta, $method);
    }
}

sub _compose_traitlibs {
    my ($spec, $traitlibs, $from_traitlib) = @_;

    if ( ! $traitlibs ) {
        $traitlibs = $spec->{traitlibs};
    }

    $from_traitlib ||= {};

    for my $traitlib ( @{ $traitlibs } ) {

        if ( $spec->{composed_traitlib}{$traitlib} ) {
            confess "Cannot compose traitlib '$traitlib' twice";
        }
        else {
            $spec->{composed_traitlib}{$traitlib}++;
        }

        my ($meta, $method) = _load_traitlib($traitlib);
        $spec->{required_by_traitlib}{$traitlib} = $meta->{requires};
        _compose_traitlibs($spec, $meta->{traitlibs} || [], $from_traitlib);

        _add_traitlib_items($spec, $from_traitlib, $traitlib, $meta->{has}, 'has');
        _add_traitlib_methods($spec, $from_traitlib, $traitlib, $meta, $method);
    }
}

sub _load_role {
    my ($role) = @_;

    my $stash  = _get_stash($role);
    my $meta   = $stash->get_symbol('%__meta__');
    $meta->{role}
      or confess "$role is not a role";

    my $method = $stash->get_all_symbols('CODE');
    return ($meta, $method);
}

sub _load_traitlib {
    my ($traitlib) = @_;

    my $stash  = _get_stash($traitlib);
    my $meta   = $stash->get_symbol('%__meta__');
    $meta->{traitlib}
      or confess "$traitlib is not a traitlib";

    my $method = $stash->get_all_symbols('CODE');
    return ($meta, $method);
}

sub _check_role_requirements {
    my ($spec) = @_;

    _check_traitlib_requirements($spec, 'required_by_role');
}

sub _check_traitlib_requirements {
    my ($spec, $type) = @_;

    $type ||= 'required_by_traitlib';
    my $required_by = do { my $tmp = $type; $tmp =~ s/_/ /g; $tmp };

    foreach my $traitlib ( keys %{ $spec->{$type} } ) {

        my $required = $spec->{$type}{$traitlib};

        foreach my $name ( @{ $required->{methods} } ) {

            unless (   defined $spec->{implementation}{methods}{$name}
                    || defined $spec->{implementation}{semiprivate}{$name}
                   ) {
                confess "Method '$name', $required_by $traitlib, is not implemented.";
            }
        }
        foreach my $name ( @{ $required->{attributes} } ) {
            defined $spec->{implementation}{has}{$name}
              or confess "Attribute '$name', $required_by $traitlib, is not defined.";
        }
    }
}

sub _check_interface {
    my ($spec) = @_;
    my $count = 0;
    foreach my $method ( @{ $spec->{interface} } ) {
        defined $spec->{implementation}{methods}{$method}
          or confess "Interface method '$method' is not implemented.";
        ++$count;
    }
    $count > 0 or confess "Cannot have an empty interface.";
}

sub _get_stash {
    my $pkg = shift;

    my $stash = Package::Stash->new($pkg); # allow for inlined pkg

    if ( ! $stash->has_symbol('%__meta__') ) {
        require_module($pkg);
        $stash = Package::Stash->new($pkg);
    }
    if ( ! $stash->has_symbol('%__meta__') ) {
        confess "Package $pkg has no %__meta__";
    }
    return $stash;
}

sub _add_role_items {
    my ($spec, $from_role, $role, $item, $type) = @_;

    for my $name ( keys %$item ) {
        if (my $other_role = $from_role->{$name}) {
            _raise_role_conflict($name, $role, $other_role);
        }
        else{
            if ( ! $spec->{implementation}{$type}{$name} ) {
                $spec->{implementation}{$type}{$name} = $item->{$name};
                $from_role->{$name} = $role;
            }
        }
    }
}

sub _add_traitlib_items {
    my ($spec, $from_traitlib, $traitlib, $item, $type) = @_;

    my $wanted = $spec->{implementation}{traitlibs}{$traitlib}{attributes};
    for my $name ( @{$wanted} ) {

        if (my $other_traitlib = $from_traitlib->{$name}) {
            _raise_role_conflict($name, $traitlib, $other_traitlib);
        }
        if (exists $item->{$name}) {
            if ( ! $spec->{implementation}{$type}{$name} ) {
                $spec->{implementation}{$type}{$name} = $item->{$name};
                $from_traitlib->{$name} = $traitlib;
            }
        }
        else {
            confess "Attribute $name not available via traitlib $traitlib";
        }
    }
}

sub _add_role_methods {
    my ($spec, $from_role, $role, $role_meta, $code_for) = @_;

    my $in_class_interface = _interface($spec);
    my $in_role_interface  = _interface($role_meta);
    my $is_semiprivate     = _interface($role_meta, 'semiprivate');

    all { defined $in_class_interface->{$_} } keys %$in_role_interface
      or Minions::Error::InterfaceMismatch->throw(
        error => "Interfaces do not match: Class => $spec->{name}, Role => $role"
      );

    for my $name ( keys %$code_for ) {
        if (    $in_role_interface->{$name}
             || $in_class_interface->{$name}
           ) {
            if (my $other_role = $from_role->{method}{$name}) {
                _raise_role_conflict($name, $role, $other_role);
            }
            if ( ! $spec->{implementation}{methods}{$name} ) {
                $spec->{implementation}{methods}{$name} = $code_for->{$name};
                $from_role->{method}{$name} = $role;
            }
        }
        elsif ( $is_semiprivate->{$name} ) {
            if (my $other_role = $from_role->{semiprivate}{$name}) {
                _raise_role_conflict($name, $role, $other_role);
            }
            if ( ! $spec->{implementation}{semiprivate}{$name} ) {
                $spec->{implementation}{semiprivate}{$name} = $code_for->{$name};
                $from_role->{semiprivate}{$name} = $role;
            }
        }
    }
}

sub _raise_role_conflict {
    my ($name, $role, $other_role) = @_;

    Minions::Error::RoleConflict->throw(
        error => "Cannot have '$name' in both $role and $other_role"
    );
}

sub _get_object_maker {

    sub {
        my ($utility_class, $init) = @_;

        my $class = $utility_class->main_class;

        my $stash = Package::Stash->new($class);

        my $spec = $stash->get_symbol('%__meta__');
        my $pkg_key = Minions::_Guts::obfu_name('', $spec);
        my %obj = (
            $pkg_key => ${ $stash->get_symbol('$__Private_pkg') },
        );

        while ( my ($attr, $meta) = each %{ $spec->{implementation}{has} } ) {
            my $obfu_name = Minions::_Guts::obfu_name($attr, $spec);
            $obj{$obfu_name} = $init->{$attr}
              ? $init->{$attr}
              : (ref $meta->{default} eq 'CODE'
                ? $meta->{default}->()
                : $meta->{default});
        }

        bless \ %obj => ${ $stash->get_symbol('$__Obj_pkg') };
        lock_keys(%obj);
        return \ %obj;
    };
}

sub _add_class_methods {
    my ($spec, $stash) = @_;

    $spec->{class_methods} ||= $stash->get_all_symbols('CODE');
    _add_default_constructor($spec);

    foreach my $sub ( keys %{ $spec->{class_methods} } ) {
        $stash->add_symbol("&$sub", $spec->{class_methods}{$sub});
        subname "$spec->{name}::$sub", $spec->{class_methods}{$sub};
    }
}

sub _make_util_class {
    my ($spec) = @_;

    my $stash = Package::Stash->new("$spec->{name}::__Util");
    $Util_class{ $spec->{name} } = $stash->name;

    my %method = (
        new_object => _get_object_maker(),
    );

    $method{main_class} = sub { $spec->{name} };

    my $obfu_pkg = Minions::_Guts::obfu_name('', $spec);
    $method{build} = sub {
        my (undef, $obj, $arg) = @_;
        if ( my $builder = $obj->{$obfu_pkg}->can('BUILD') ) {
            $builder->($obj->{$obfu_pkg}, $obj, $arg);
        }
    };

    $method{assert} = sub {
        my (undef, $slot, $val) = @_;

        return unless exists $spec->{construct_with}{$slot};

        my $meta = $spec->{construct_with}{$slot};

        for my $desc ( keys %{ $meta->{assert} || {} } ) {
            my $code = $meta->{assert}{$desc};
            $code->($val)
              or assert_failed error => "Parameter '$slot' failed check '$desc'";
        }
    };

    my $class_var_stash = Package::Stash->new("$spec->{name}::__ClassVar");

    $method{get_var} = sub {
        my ($class, $name) = @_;
        $class_var_stash->get_symbol($name);
    };

    $method{set_var} = sub {
        my ($class, $name, $val) = @_;
        $class_var_stash->add_symbol($name, $val);
    };

    foreach my $sub ( keys %method ) {
        $stash->add_symbol("&$sub", $method{$sub});
        subname $stash->name."::$sub", $method{$sub};
    }
}

sub _add_default_constructor {
    my ($spec) = @_;

    if ( ! exists $spec->{class_methods}{new} ) {
        $spec->{class_methods}{new} = sub {
            my $class = shift;
            my ($arg);

            if ( scalar @_ == 1 ) {
                $arg = shift;
            }
            elsif ( scalar @_ > 1 ) {
                $arg = { @_ };
            }
            if (my @unknown = grep { ! exists $spec->{construct_with}{$_} } keys %$arg) {
                confess "Unknown args: [@unknown]";
            }

            my $utility_class = utility_class($class);
            my $obj = $utility_class->new_object;
            for my $name ( keys %{ $spec->{construct_with} } ) {

                if ( ! $spec->{construct_with}{$name}{optional} && ! defined $arg->{$name} ) {
                    confess "Param '$name' was not provided.";
                }
                if ( defined $arg->{$name} ) {
                    $utility_class->assert($name, $arg->{$name});
                }

                my ($attr, $dup) = grep { $spec->{implementation}{has}{$_}{init_arg} eq $name }
                                        keys %{ $spec->{implementation}{has} };
                if ( $dup ) {
                    confess "Cannot have same init_arg '$name' for attributes '$attr' and '$dup'";
                }
                if ( $attr ) {
                    _copy_assertions($spec, $name, $attr);
                    my $sub = $spec->{implementation}{has}{$attr}{map_init_arg};
                    my $obfu_name = Minions::_Guts::obfu_name($attr, $spec) ;
                    $obj->{$obfu_name} = $sub ? $sub->($arg->{$name}) : $arg->{$name};
                }
            }

            $utility_class->build($obj, $arg);
            return $obj;
        };

        my $build_args = $spec->{build_args} || $spec->{class_methods}{BUILDARGS};
        if ( $build_args ) {
            my $prev_new = $spec->{class_methods}{new};

            $spec->{class_methods}{new} = sub {
                my $class = shift;
                $prev_new->($class, $build_args->($class, @_));
            };
        }
    }
}

sub _copy_assertions {
    my ($spec, $name, $attr) = @_;

    my $meta = $spec->{construct_with}{$name};

    for my $desc ( keys %{ $meta->{assert} || {} } ) {
        next if exists $spec->{implementation}{has}{$attr}{assert}{$desc};

        $spec->{implementation}{has}{$attr}{assert}{$desc} = $meta->{assert}{$desc};
    }
}

sub _add_methods {
    my ($spec, $stash, $private_stash) = @_;

    my $in_interface = _interface($spec);

    $spec->{implementation}{semiprivate}{ASSERT} = sub {
        my (undef, $slot, $val) = @_;

        return unless exists $spec->{implementation}{has}{$slot};

        my $meta = $spec->{implementation}{has}{$slot};

        for my $desc ( keys %{ $meta->{assert} || {} } ) {
            my $code = $meta->{assert}{$desc};
            $code->($val)
              or assert_failed error => "Attribute '$slot' failed check '$desc'";
        }
    };
    $spec->{implementation}{methods}{DOES} = sub {
        my ($self, $r) = @_;

        if ( ! $r ) {
            my @items = (( $spec->{interface_name} ? $spec->{interface_name} : () ),
                          $spec->{name}, sort keys %{ $spec->{composed_role} });
            return unless defined wantarray;
            return wantarray ? @items : \@items;
        }

        return    $r eq $spec->{interface_name}
               || $spec->{name} eq $r
               || $spec->{composed_role}{$r}
               || $self->isa($r);
    };
    $spec->{implementation}{methods}{can} = sub {
        my ($self, $f) = @_;

        if ( ! $f ) {
            my @items = sort @{ $spec->{interface} };
            return unless defined wantarray;
            return wantarray ? @items : \@items;
        }
        return UNIVERSAL::can($self, $f);
    };
    _add_autoload($spec, $stash);

    while ( my ($name, $meta) = each %{ $spec->{implementation}{has} } ) {

        if ( !  $spec->{implementation}{methods}{$name}
             && $meta->{reader}
             && $in_interface->{$name} ) {

            my $name = $meta->{reader} == 1 ? $name : $meta->{reader};
            my $obfu_name = Minions::_Guts::obfu_name($name, $spec);
            $spec->{implementation}{methods}{$name} = sub { $_[0]->{$obfu_name} };
        }

        if ( !  $spec->{implementation}{methods}{$name}
             && $meta->{writer}
             && $in_interface->{$name} ) {

            my $name = $meta->{writer};
            my $obfu_pkg = Minions::_Guts::obfu_name('', $spec);
            $spec->{implementation}{methods}{$name} = sub {
                my ($self, $new_val) = @_;

                $self->{$obfu_pkg}->ASSERT($name, $new_val);
                $self->{ Minions::_Guts::obfu_name($name, $spec) } = $new_val;
                return $self;
            };
        }
        _add_delegates($spec, $meta, $name);
    }

    while ( my ($name, $sub) = each %{ $spec->{implementation}{methods} } ) {
        next unless $in_interface->{$name};
        $stash->add_symbol("&$name", subname $stash->name."::$name" => $sub);
    }
    while ( my ($name, $sub) = each %{ $spec->{implementation}{semiprivate} } ) {
        $private_stash->add_symbol("&$name", subname $private_stash->name."::$name" => $sub);
    }
}

sub _add_autoload {
    my ($spec, $stash) = @_;

    $spec->{implementation}{methods}{AUTOLOAD} = sub {
        my $self = shift;

        my $caller_sub = (caller 1)[3];
        my $caller_pkg = $caller_sub;
        $caller_pkg =~ s/::[^:]+$//;

        my $called = ${ $stash->get_symbol('$AUTOLOAD') };
        $called =~ s/.+:://;

        if(    exists $spec->{implementation}{semiprivate}{$called}
            && $caller_pkg eq ref $self
        ) {
            my $stash = _get_stash($spec->{implementation}{package});
            my $sp_var = ${ $stash->get_symbol('$__') };
            return $self->{$sp_var}->$called($self, @_);
        }
        elsif( $called eq 'DESTROY' ) {
            return;
        }
        else {
            croak sprintf(q{Can't locate object method "%s" via package "%s"},
                          $called, ref $self);
        }
    };
}

sub _add_delegates {
    my ($spec, $meta, $name) = @_;

    if ( $meta->{handles} ) {
        my $method;
        my $target_method = {};
        if ( ref $meta->{handles} eq 'ARRAY' ) {
            $method = { map { $_ => 1 } @{ $meta->{handles} } };
        }
        elsif( ref $meta->{handles} eq 'HASH' ) {
            $method = $meta->{handles};
            $target_method = $method;
        }
        elsif( ! ref $meta->{handles} ) {
            (undef, $method) = _load_role($meta->{handles});
        }
        my $in_interface = _interface($spec);
        my $obfu_name = Minions::_Guts::obfu_name($name, $spec);

        foreach my $meth ( keys %{ $method } ) {
            if ( defined $spec->{implementation}{methods}{$meth} ) {
                confess "Cannot override implemented method '$meth' with a delegated method";
            }
            else {
                my $target = $target_method->{$meth} || $meth;
                $spec->{implementation}{methods}{$meth} =
                  $in_interface->{$meth}
                    ? sub { shift->{$obfu_name}->$target(@_) }
                    : sub { shift; shift->{$obfu_name}->$target(@_) };
            }
        }
    }
}

sub _interface {
    my ($spec, $type) = @_;

    $type ||= 'interface';
    my %must_allow = (
        interface   => [qw( AUTOLOAD can DOES DESTROY )],
        semiprivate => [qw( BUILD )],
    );
    return { map { $_ => 1 } @{ $spec->{$type} }, @{ $must_allow{$type} } };
}

1;
__END__