|
278
|
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; |
