File Coverage

blib/lib/MooX/Prototype.pm

Criterion	Covered	Total	%
statement	22	72	30.5
branch	0	22	0.0
condition	0	23	0.0
subroutine	6	14	42.8
pod	0	7	0.0
total	28	138	20.2

# ABSTRACT: Prototype-based Programming
package MooX::Prototype;

use Moo;
use Carp;

our $VERSION = '0.01'; # VERSION

sub import {
    my $class  = shift;
    my $target = caller;

    no strict 'refs';
    *{"${target}::extend"} = $class->can('build_clone');
    *{"${target}::object"} = $class->can('build_object');

    return;
}

sub build_args {
    my $left  = shift or return;
    my $right = shift or return;

    my $hash = {%$left};
    if ('HASH' eq ref $right) {
        while (my($key, $val) = each %$right) {
            my $is_hash = 'HASH' eq ref $val;
            $hash->{$key} = $is_hash ? build_args({}, $val) : $val;
        }
    }

    return $hash;
}

sub build_attribute ($$$) {
    my $class = shift;
    my $key   = shift;
    my $value = shift;

    $class = ref($class) || $class;
    my @default = (default => $value) if defined $value;
    $class->can('has')->($key => (is => 'rw', @default));

    return $value;
}

my $serial = 0;
sub build_class (;$) {
    my $base  = shift;
    my $class = join '::', __PACKAGE__, 'Instance';

    $base //= $class;

    my $name = sprintf '%s::__ANON__::%04d', $class, ++$serial;
    my $modern = $base->isa($class) || $base eq $class;
    my $inherit = $modern ? "extends '$base'" : "use base '$base'";

    eval join ';', ("package $name", "use Moo", $inherit);
    croak $@ if $@;

    return $name;
}

sub build_clone (@) {
    my $class  = shift;
    my $common = join '::', __PACKAGE__, 'Instance';

    my $base = ref($class) || $class;
    my $args = ref($class) ? {%{$class}} : {};
    build_properties(my $name = build_class($base), @_);

    return $name->new($base->isa($common) ? (%{build_args($args, {@_})}) : @_);
}

sub build_method ($$$) {
    my $class = shift;
    my $key   = shift;
    my $value = shift;

    $class = ref($class) || $class;
    no strict 'refs';
    no warnings 'redefine';
    *{"${class}::$key"} = $value;

    return $value;
}

sub build_properties ($;@) {
    my $class = shift;
    my %properties = @_;

    $class = ref($class) || $class;
    while (my ($key, $val) = each %properties) {
        my $is_code = 'CODE' eq ref $val;
        build_method $class, $key, $val and next if $val and $is_code;
        build_attribute $class, $key, ref $val ? sub { $val } : $val;
    }

    return;
}

sub build_object (@) {
    build_properties(my $name = build_class, @_);
    return $name->new;
}

1;

__END__