File Coverage

blib/lib/Object/Factory/Declarative.pm

Criterion	Covered	Total	%
statement	94	137	68.6
branch	21	52	40.3
condition	4	13	30.7
subroutine	16	23	69.5
pod	0	5	0.0
total	135	230	58.7

package Object::Factory::Declarative;

use 5.006;
use strict;
use warnings;
use Carp;

our @ISA = qw();

our $VERSION = '0.07';

my @decl_keys = qw(constructor constructor_args method method_args package);

sub expand_scalar_arg
{
    my ($obj, $name, $arg) = @_;
    my @res = ($arg);
    if(@_>3)
    {
        my $opt = $_[3];
        eval { no warnings; @res = $obj->$arg($opt, $name); };
    }
    else
    {
        eval { no warnings; @res = $obj->$arg($name); };
    }
    wantarray?@res:pop @res;
}

sub expand_array_arg
{
    my ($obj, $name, @args) = @_;
    my @res;
    push @res, expand_scalar_arg($obj, $name, $_) foreach @args;
    wantarray?@res:pop @res;
}

sub expand_hash_arg
{
    my ($obj, $name, @args) = @_;
    return expand_array_arg($obj, $name, @args) if @args&1;
    my @res;
    my %args = @args;
    push @res, $_, expand_scalar_arg($obj, $name, $args{$_}, $_)
        foreach keys %args;
    wantarray?@res:pop @res;
}

sub expand_credentials
{
    my ($argf) = @_;
    return sub {} unless defined $argf;
    return (\&expand_scalar_arg, $argf) unless ref $argf;
    my @res = ($argf);
    eval { no warnings; @res = @$argf; };
    return (\&expand_array_arg, @res) unless $@;
    eval { no warnings; @res = %$argf; };
    return (\&expand_hash_arg, @res) unless $@;
    return (\&expand_scalar_arg, @res);
}

sub generate_method
{
    my ($class, $name, $cons, $c_args, $init, $i_args) = @_;
    my $package = ref $class || $class;
    my $fullname = $package . '::' . $name;
    my ($cons_expand_func, @c_args) = expand_credentials($c_args);
    my ($init_expand_func, @i_args) = expand_credentials($i_args);
    no strict 'refs';
    # We have several similar cases...
    # Case 1a & 1b - no init method
    unless($init)
    {
        # 1a - with constructor args
        if(@c_args)
        {
            *$fullname = sub
            {
                my ($obj) = @_;
                $obj->$cons(&{$cons_expand_func}($obj, $name, @c_args));
            } ;
        }
        # 2a - without constructor args
        else
        {
            *$fullname = sub
            {
                my ($obj) = @_;
                $obj->$cons;
            } ;
        }
        return;
    }
    # Case 2a & 2b - init method, no init args
    unless(@i_args)
    {
        # 2a - with constructor args
        if(@c_args)
        {
            *$fullname = sub
            {
                my ($obj, @args) = @_;
                my $rv = $obj->$cons(&{$cons_expand_func}($obj,
                                    $name, @c_args));
                $rv->$init;
                # expand_hash_arg will convert to expand_array_arg...
                $rv->$init(expand_hash_arg($obj, $name, @args)) if @args;
                $rv;
            } ;
        }
        # 2b - without constructor args
        else
        {
            *$fullname = sub
            {
                my ($obj, @args) = @_;
                my $rv = $obj->$cons;
                $rv->$init;
                # expand_hash_arg will convert to expand_array_arg...
                $rv->$init(expand_hash_arg($rv, $name, @args)) if @args;
                $rv;
            } ;
        }
        return;
    }
    # Case 3a & 3b - init with args
    # 3a - with constructor args
    if(@c_args)
    {
        *$fullname = sub
        {
            my ($obj, @args) = @_;
            my $rv = $obj->$cons(&{$cons_expand_func}($obj,
                $name, @c_args));
            $rv->$init(&{$init_expand_func}($obj, $name, @i_args));
            $rv->$init(&{$init_expand_func}($obj, $name, @args)) if @args;
            $rv;
        } ;
    }
    # 3b - without constructor args
    else
    {
        *$fullname = sub
        {
            my ($obj, @args) = @_;
            my $rv = $obj->$cons;
            $rv->$init(&{$init_expand_func}($obj, $name, @i_args));
            $rv->$init(&{$init_expand_func}($obj, $name, @args)) if @args;
            $rv;
        } ;
    }
}

sub import
{
    my ($package, @args) = @_;
    carp "Expected an even number of arguments" and return if @args&1;
    my $callpkg = caller;
    my %defaults =
    (
        package => $callpkg,
    ) ;
    while(@args)
    {
        my ($name, $ref) = splice @args, 0, 2;
        my %h;
        if('--defaults' eq $name)
        {
            %defaults = ( package => $callpkg );
            %h = %$ref;
            foreach my $k (grep { exists $h{$_}; } @decl_keys)
            {
                delete $defaults{$k};
                my $v = delete $h{$k};
                $defaults{$k} = $v if defined $v;
            }
            carp "Unexpected declaration key(s) ", join(',', keys %h) if %h;
            next;
        }
        if('--export-to' eq $name)
        {
            no strict 'refs';
            *$ref = \&generate_method;
            next;
        }
        %h = %$ref;
        my %p;
        $p{$_} = delete $h{$_} || $defaults{$_} foreach @decl_keys;
        carp "Unexpected declaration key(s) ", join(',', keys %h) if %h;
        carp "Can't have initialization args without an initialization method"
            if $p{method_args} and not $p{method};
        carp "Missing constructor" and next unless $p{constructor};
        generate_method($p{package}, $name, @p{qw(constructor constructor_args
            method method_args)});
    }
}

1;
__END__