view Lib/IMPL/Code/AccessorPropertyImplementor.pm @ 361:eff7f75a4408

added cookie support for the request language detection
author cin
date Wed, 27 Nov 2013 17:12:38 +0400
parents 4ddb27ff4a0b
children
line wrap: on
line source

package IMPL::Code::AccessorPropertyImplementor;
use strict;

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

require IMPL::Class::AccessorPropertyInfo;
require IMPL::Object::List;

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

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

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 = $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
    };
    
    delete @$spec{qw(get set ownerSet isList name class type access field direct)};
    
    $args->{attributes} = $spec;
    
    my $propInfo = AccessorPropertyInfo->new($args);
    
    {
        no strict 'refs';
        *{"${class}::$name"} = $accessor;
    }
    
    $class->SetMeta($propInfo);
    
    return $propInfo;
}

1;