File Coverage

blib/lib/Data/Object/Prototype.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

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

use 5.10.0;

use strict;
use warnings;

use Carp ();

use Data::Object::Class;
use Data::Object::Signatures;

use Data::Object::Prototype::Attribute;
use Data::Object::Prototype::Method;

use Data::Object::Library -types;

our $VERSION = '0.03'; # VERSION

has 'package' => (
    is      => 'ro',
    isa     => Str,
    default => fun { join '::', ref shift, '__ANON__' },
    lazy    => 1,
);

has 'series' => (
    is      => 'ro',
    isa     => Str,
    default => fun { join '::', shift->package, 'Instance' },
    lazy    => 1,
);

has 'inherits' => (
    is      => 'ro',
    isa     => ArrayObj[Str],
    default => fun { [] },
    coerce  => 1,
    lazy    => 1,
);

has 'includes' => (
    is      => 'ro',
    isa     => ArrayObj[Str],
    default => fun { [] },
    coerce  => 1,
    lazy    => 1,
);

has 'attributes' => (
    is      => 'ro',
    isa     => ArrayObj[InstanceOf['Data::Object::Prototype::Attribute']],
    default => fun { [] },
    coerce  => 1,
    lazy    => 1,
);

has 'methods' => (
    is      => 'ro',
    isa     => ArrayObj[InstanceOf['Data::Object::Prototype::Method']],
    default => fun { [] },
    coerce  => 1,
    lazy    => 1,
);

fun BUILDARGS ($class, %args) {
    my @properties = grep qr/^[\&\$]/, sort keys %args;

    for my $key (@properties) {
        if (my ($name) = $key =~ /\$(\w+)/) {
            push @{$args{attributes}} =>
                Data::Object::Prototype::Attribute->new(
                    name    => $name,
                    options => $args{$key},

                );
        }
        if (my ($name) = $key =~ /\&(\w+)/) {
            push @{$args{methods}} =>
                Data::Object::Prototype::Method->new(
                    name    => $name,
                    routine => $args{$key},
                );

        }
    }

    return \%args;
}

my %counter;
method class () {
    my $series    = $self->series;
    my $format    = join '::', $series, '%04d';
    my $instance  = sprintf $format, ++$counter{$series};
    my @statement = "package $instance";
    my @supers    = 'Data::Object::Prototype::Instance';
    my $default   = 'Data::Object::Class';

    if (my $inherits = $self->inherits) {
        push @supers, $inherits->list;
    }

    push @statement, "use $default",
        map "extends '$_'", @supers, ();

    unless ($counter{$instance}++) {
        local $@; eval join '; ', @statement; Carp::croak $@ if $@;
    }

    my $package = $instance->package;

    $package->method(prototype => sub { $self });

    my $methods = $self->methods;
    for my $method ($methods->list) {
        my $name = $method->name;
        my $data = $method->routine->data;
        $package->method($name, $data);
    }

    my $includes = $self->includes;
    for my $include ($includes->list) {
        $package->mixin_role($include);
    }

    my $attributes = $self->attributes;
    for my $attribute ($attributes->list) {
        my $name = $attribute->name;
        my $data = $attribute->options;
        $package->attribute($name, @$data);
    }

    return $instance;
}

method create ($class: %args) {
    return $class->new(%args)->class;
}

method extend (%args) {
    $args{package}    //= $self->package,
    $args{series}     //= $self->series,
    $args{inherits}   //= $self->inherits,
    $args{includes}   //= $self->includes,
    $args{attributes} //= $self->attributes,
    $args{methods}    //= $self->methods,

    return ref($self)->new(%args)->class;
}

1;

__END__