view Lib/IMPL/Code/DirectPropertyImplementor.pm @ 379:a471e8b77544

sync
author cin
date Thu, 16 Jan 2014 18:10:50 +0400
parents 4ddb27ff4a0b
children
line wrap: on
line source

package IMPL::Code::DirectPropertyImplementor;
use strict;

require IMPL::Object::List;

use IMPL::lang qw(:hash);
use IMPL::require {
	Exception => 'IMPL::Exception',
	ArgException => '-IMPL::InvalidArgumentException',
	DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo'
};

use parent qw(IMPL::Code::BasePropertyImplementor);

use constant {
	CodeGetAccessor => 'return ($this->{$field});',
	CodeSetAccessor => 'return ($this->{$field} = $_[0])',
	CodeGetListAccessor => 'return(
        wantarray ?
        @{ $this->{$field} ?
            $this->{$field} :
            ( $this->{$field} = IMPL::Object::List->new() )
        } :
        ( $this->{$field} ?
            $this->{$field} :
            ( $this->{$field} = IMPL::Object::List->new() )
        )
    );',
    CodeSetListAccessor => 'return(
        wantarray ?
        @{ $this->{$field} = IMPL::Object::List->new(
            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
        )} : 
        ($this->{$field} = IMPL::Object::List->new(
            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
        ))
    );'
};

sub factoryParams { qw($class $name $get $set $validator $field) };

my %cache;

sub Implement {
	my $self = shift;
	
	my $spec = {};
    
    map hashApply($spec,$self->NormalizeSpecification($_)), @_;
	
	my $name = $spec->{name}
        or ArgException->new(name => "The name of the property is required");
    my $class = $spec->{class}
        or ArgException->new(name => "The onwer class must be specified");
	
	my $id = $self->CreateFactoryId($spec);
	my $factory = $cache{$id};
	unless($factory) {
        $factory = $self->CreateFactory($spec);
        $cache{$id} = $factory;		
	}
	
	my $field = join( '_', split(/::/, $class), $name);
	
	my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field);
	
	my $args = {
	    getter => $spec->{get} ? $accessor : undef,
	    setter => $spec->{set} ? $accessor : undef,
	    ownetSet => $spec->{ownerSet} ? 1 : 0,
	    isList => $spec->{isList} ? 1 : 0,
	    name => $spec->{name},
	    class => $spec->{class},
	    type => $spec->{type},
	    access => $spec->{access},
	    fieldName => $field,
	    directAccess => $spec->{direct}
	};
	
	delete @$spec{qw(get set ownerSet isList name class type access field direct)};
	
	$args->{attributes} = $spec;
	
	my $propInfo = DirectPropertyInfo->new($args);
	
	{
	    no strict 'refs';
	    *{"${class}::$name"} = $accessor;
	    *{"${class}::$name"} = \$field if $args->{directAccess};
	}
	$class->SetMeta($propInfo);
	
	return $propInfo;
}

1;