annotate Lib/IMPL/Code/DirectPropertyImplementor.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
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
1 package IMPL::Code::DirectPropertyImplementor;
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
2 use strict;
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
3
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
4 require IMPL::Object::List;
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
5
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
6 use IMPL::lang qw(:hash);
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
7 use IMPL::require {
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
8 Exception => 'IMPL::Exception',
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
9 ArgException => '-IMPL::InvalidArgumentException',
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
10 DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo'
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
11 };
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
12
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
13 use parent qw(IMPL::Code::BasePropertyImplementor);
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
14
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
15 use constant {
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
16 CodeGetAccessor => 'return ($this->{$field});',
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
17 CodeSetAccessor => 'return ($this->{$field} = $_[0])',
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
18 CodeGetListAccessor => 'return(
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
19 wantarray ?
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
20 @{ $this->{$field} ?
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
21 $this->{$field} :
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
22 ( $this->{$field} = IMPL::Object::List->new() )
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
23 } :
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
24 ( $this->{$field} ?
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
25 $this->{$field} :
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
26 ( $this->{$field} = IMPL::Object::List->new() )
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
27 )
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
28 );',
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
29 CodeSetListAccessor => 'return(
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
30 wantarray ?
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
31 @{ $this->{$field} = IMPL::Object::List->new(
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
32 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
33 )} :
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
34 ($this->{$field} = IMPL::Object::List->new(
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
35 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
36 ))
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
37 );'
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
38 };
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
39
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
40 sub factoryParams { qw($class $name $get $set $validator $field) };
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
41
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
42 my %cache;
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
43
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
44 sub Implement {
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
45 my $self = shift;
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
46
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
47 my $spec = {};
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
48
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
49 map hashApply($spec,$self->NormalizeSpecification($_)), @_;
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
50
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
51 my $name = $spec->{name}
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
52 or ArgException->new(name => "The name of the property is required");
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
53 my $class = $spec->{class}
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
54 or ArgException->new(name => "The onwer class must be specified");
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
55
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
56 my $id = $self->CreateFactoryId($spec);
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
57 my $factory = $cache{$id};
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
58 unless($factory) {
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
59 $factory = $self->CreateFactory($spec);
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
60 $cache{$id} = $factory;
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
61 }
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
62
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
63 my $field = join( '_', split(/::/, $class), $name);
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
64
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
65 my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field);
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
66
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
67 my $args = {
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
68 getter => $spec->{get} ? $accessor : undef,
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
69 setter => $spec->{set} ? $accessor : undef,
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
70 ownetSet => $spec->{ownerSet} ? 1 : 0,
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
71 isList => $spec->{isList} ? 1 : 0,
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
72 name => $spec->{name},
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
73 class => $spec->{class},
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
74 type => $spec->{type},
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
75 access => $spec->{access},
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
76 fieldName => $field,
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
77 directAccess => $spec->{direct}
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
78 };
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
79
278
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
80 delete @$spec{qw(get set ownerSet isList name class type access field direct)};
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
81
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
82 $args->{attributes} = $spec;
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
83
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
84 my $propInfo = DirectPropertyInfo->new($args);
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
85
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
86 {
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
87 no strict 'refs';
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
88 *{"${class}::$name"} = $accessor;
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
89 *{"${class}::$name"} = \$field if $args->{directAccess};
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
90 }
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
91 $class->SetMeta($propInfo);
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
92
4ddb27ff4a0b core refactoring
cin
parents: 277
diff changeset
93 return $propInfo;
277
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
94 }
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
95
6585464c4664 sync (unstable)
sergey
parents:
diff changeset
96 1;