annotate Lib/IMPL/Code/AccessorPropertyImplementor.pm @ 393:69a1f1508696

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