File Coverage

blib/lib/Data/Object/Prototype.pm

Criterion	Covered	Total	%
statement	79	79	100.0
branch	6	10	60.0
condition	3	8	37.5
subroutine	20	20	100.0
pod	0	3	0.0
total	108	120	90.0

# ABSTRACT: Data::Object Prototype-based Programming
package Data::Object::Prototype;

use 5.10.0;

use strict;
use warnings;

use Carp qw(croak);
use Clone qw(clone);
use Data::Object qw(deduce_type);
use Scalar::Util qw(blessed);

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;
}

my $serial = 0;
sub build_class (@) {
    my $type = shift;
    my $base = shift;

    my $mappings = {
        'ARRAY'     =>  'Data::Object::Array',
        'HASH'      =>  'Data::Object::Hash',
        'CODE'      =>  'Data::Object::Code',
        'FLOAT'     =>  'Data::Object::Float',
        'NUMBER'    =>  'Data::Object::Number',
        'INTEGER'   =>  'Data::Object::Integer',
        'STRING'    =>  'Data::Object::String',
        'SCALAR'    =>  'Data::Object::Scalar',
        'REGEXP'    =>  'Data::Object::Regexp',
        'UNDEF'     =>  'Data::Object::Undef',
        'UNIVERSAL' =>  'Data::Object::Universal',
    };

    my $class = join '::', __PACKAGE__, 'Instance';

    $type = $mappings->{$type} // 'Data::Object::Universal';
    $base = $class unless $base;

    my $format  = '%s::__ANON__::%04d';
    my $package = sprintf $format, $class, ++$serial;
    my @supers  = ("use base '$type'", "use base '$base'");

    eval join '; ', ("package $package", @supers);

    croak $@ if $@;

    return $package;
}

sub build_clone (@) {
    my $class = shift;
    my $args  = shift;

    $args = clone $class->data if not defined $args && ref $class;

    my $type  = deduce_type $class;
    my $clone = build_class $type, ref($class) || $class;

    $args = blessed $args ? $args->data : $args;

    return $clone->new($args);
}

sub build_object (@) {
    my $args = shift;

    my $type  = deduce_type $args;
    my $class = build_class $type;

    $args = blessed $args ? $args->data : $args;

    return $class->new($args);
}

1;

__END__