File Coverage

blib/lib/MooX/Prototype.pm

Criterion	Covered	Total	%
statement	88	89	98.8
branch	19	28	67.8
condition	12	23	52.1
subroutine	17	18	94.4
pod	0	7	0.0
total	136	165	82.4

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

use Carp;

our $VERSION = '0.02'; # 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 $data;

    my $hash = {%$left};
    return $hash unless 'HASH' eq ref $right;

    while (my($key, $val) = each %$right) {
        if ('HASH' eq ref $val) {
            $hash->{$key} = build_args({}, $val);
        }
        elsif ('ARRAY' eq ref  $val) {
            $hash->{$key} = [
                map { 'HASH' eq ref $_ ? build_args({}, $_) : $_ } @$val
            ];
        }
        else {
            $hash->{$key} = $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(build_args({},$args), {@_})}) : @_
    );
}

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

    $class = ref($class) || $class;
    return unless 'CODE' eq ref $value;

    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__