Mercurial > pub > Impl

comparison Lib/IMPL/Code/AccessorPropertyImplementor.pm @ 278:4ddb27ff4a0b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
core refactoring
author cin
date Mon, 04 Feb 2013 02:10:37 +0400
parents
children
comparison
equal deleted inserted replaced
277:6585464c4664 278:4ddb27ff4a0b
1 package IMPL::Code::AccessorPropertyImplementor;
2 use strict;
3
4 use IMPL::lang qw(:hash);
5 use IMPL::require {
6 Exception => '-IMPL::Exception',
7 ArgException => '-IMPL::InvalidArgumentException',
8 AccessorPropertyInfo => '-IMPL::Class::AccessorPropertyInfo'
9 };
10
11 require IMPL::Class::AccessorPropertyInfo;
12 require IMPL::Object::List;
13
14 use parent qw(IMPL::Code::BasePropertyImplementor);
15
16 use constant {
17 CodeGetAccessor => 'return $this->get($field);',
18 CodeSetAccessor => 'return $this->set($field,@_);',
19 CodeSetListAccessor =>
20 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] );
21 $this->set($field,$val);
22 return( wantarray ? @{ $val } : $val );',
23 CodeGetListAccessor =>
24 'my $val = $this->get($field);
25 $this->set($field,$val = IMPL::Object::List->new()) unless $val;
26 return( wantarray ? @{ $val } : $val );'
27 };
28
29 sub factoryParams { qw($class $name $get $set $validator $field) };
30
31 my %cache;
32
33 sub Implement {
34 my $self = shift;
35
36 my $spec = {};
37
38 map hashApply($spec,$self->NormalizeSpecification($_)), @_;
39
40 my $name = $spec->{name}
41 or ArgException->new(name => "The name of the property is required");
42 my $class = $spec->{class}
43 or ArgException->new(name => "The onwer class must be specified");
44
45 my $id = $self->CreateFactoryId($spec);
46 my $factory = $cache{$id};
47 unless($factory) {
48 $factory = $self->CreateFactory($spec);
49 $cache{$id} = $factory;
50 }
51
52 my $field = $name;
53
54 my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field);
55
56 my $args = {
57 getter => $spec->{get} ? $accessor : undef,
58 setter => $spec->{set} ? $accessor : undef,
59 ownetSet => $spec->{ownerSet} ? 1 : 0,
60 isList => $spec->{isList} ? 1 : 0,
61 name => $spec->{name},
62 class => $spec->{class},
63 type => $spec->{type},
64 access => $spec->{access},
65 fieldName => $field
66 };
67
68 delete @$spec{qw(get set ownerSet isList name class type access field direct)};
69
70 $args->{attributes} = $spec;
71
72 my $propInfo = AccessorPropertyInfo->new($args);
73
74 {
75 no strict 'refs';
76 *{"${class}::$name"} = $accessor;
77 }
78
79 $class->SetMeta($propInfo);
80
81 return $propInfo;
82 }
83
84 1;