|
49
|
1 package IMPL::Class::Property::Direct;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use base qw(IMPL::Object::Accessor Exporter);
|
|
|
5 our @EXPORT = qw(_direct);
|
|
|
6
|
|
55
|
7 require IMPL::Object::List;
|
|
49
|
8 use IMPL::Class::Property;
|
|
|
9 require IMPL::Exception;
|
|
|
10
|
|
|
11 __PACKAGE__->mk_accessors qw(ExportField);
|
|
|
12
|
|
|
13 sub _direct($) {
|
|
|
14 my ($prop_info) = @_;
|
|
|
15 $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) );
|
|
|
16 return $prop_info;
|
|
|
17 }
|
|
|
18
|
|
|
19 my $access_private = "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;";
|
|
|
20 my $access_protected = "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless caller eq \$class;";
|
|
|
21
|
|
|
22 my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;';
|
|
|
23 my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;';
|
|
|
24 my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );';
|
|
|
25 my $accessor_get = 'return( $this->{$field} );';
|
|
55
|
26 my $list_accessor_set = 'return(
|
|
|
27 wantarray ?
|
|
|
28 @{ $this->{$field} = IMPL::Object::List->new(
|
|
|
29 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
|
|
|
30 )} :
|
|
|
31 ($this->{$field} = IMPL::Object::List->new(
|
|
|
32 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
|
|
|
33 ))
|
|
|
34 );';
|
|
|
35 my $list_accessor_get = 'return(
|
|
|
36 wantarray ?
|
|
|
37 @{ $this->{$field} ?
|
|
|
38 $this->{$field} :
|
|
|
39 ( $this->{$field} = IMPL::Object::List->new() )
|
|
|
40 } :
|
|
|
41 ( $this->{$field} ?
|
|
|
42 $this->{$field} :
|
|
|
43 ( $this->{$field} = IMPL::Object::List->new() )
|
|
|
44 )
|
|
|
45 );';
|
|
49
|
46 my $custom_accessor_get = 'unshift @_, $this and goto &$get;';
|
|
|
47 my $custom_accessor_set = 'unshift @_, $this and goto &$set;';
|
|
|
48
|
|
|
49 my %accessor_cache;
|
|
|
50 sub mk_acessor {
|
|
55
|
51 my ($virtual,$access,$class,$name,$mutators,$field,$validator) = @_;
|
|
49
|
52
|
|
|
53 my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set);
|
|
55
|
54 my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')), $validator ? 1 : 0 ;
|
|
49
|
55 my $factory = $accessor_cache{$key};
|
|
|
56 if (not $factory) {
|
|
|
57 my $code =
|
|
|
58 <<BEGIN;
|
|
|
59 sub {
|
|
|
60 my (\$class,\$name,\$set,\$get,\$field) = \@_;
|
|
|
61 my \$accessor;
|
|
|
62 \$accessor = sub {
|
|
|
63 my \$this = shift;
|
|
|
64 BEGIN
|
|
|
65 $code .= <<VCALL if $virtual;
|
|
|
66 my \$method = \$this->can(\$name);
|
|
|
67 return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class);
|
|
|
68 VCALL
|
|
55
|
69 $code .= ' 'x8 . "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE;
|
|
|
70 $code .= ' 'x8 . "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED;
|
|
|
71 $code .= ' 'x8 . '$this->$validator(@_);'."\n" if $validator;
|
|
|
72
|
|
49
|
73 my ($codeGet,$codeSet);
|
|
|
74 if (ref $mutators) {
|
|
|
75 $codeGet = $get ? $custom_accessor_get : $accessor_get_no;
|
|
|
76 $codeSet = $set ? $custom_accessor_set : $accessor_set_no;
|
|
|
77 } else {
|
|
|
78 if ($mutators & prop_list) {
|
|
|
79 $codeGet = $get ? $list_accessor_get : $accessor_get_no;
|
|
|
80 $codeSet = $set ? $list_accessor_set : $accessor_set_no;
|
|
|
81 } else {
|
|
|
82 $codeGet = $get ? $accessor_get : $accessor_get_no;
|
|
|
83 $codeSet = $set ? $accessor_set : $accessor_set_no;
|
|
|
84 }
|
|
|
85 }
|
|
|
86 $code .=
|
|
|
87 <<END;
|
|
|
88 if (\@_) {
|
|
|
89 $codeSet
|
|
|
90 } else {
|
|
|
91 $codeGet
|
|
|
92 }
|
|
|
93 }
|
|
|
94 }
|
|
|
95 END
|
|
55
|
96 warn $code;
|
|
|
97 $factory = eval $code;
|
|
|
98 if (not $factory) {
|
|
|
99 my $err = $@;
|
|
|
100 die new IMPL::Exception('Failed to generate the accessor factory',$err);
|
|
|
101 }
|
|
49
|
102 $accessor_cache{$key} = $factory;
|
|
|
103 }
|
|
55
|
104
|
|
|
105 die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator);
|
|
|
106
|
|
|
107 return $factory->($class,$name,$set,$get, $field, $validator);
|
|
49
|
108 }
|
|
|
109
|
|
|
110 sub Make {
|
|
|
111 my ($self,$propInfo) = @_;
|
|
|
112
|
|
|
113 my $isExportField = ref $self ? ($self->ExportField || 0) : 0;
|
|
55
|
114 my ($class,$name,$virt,$access,$mutators,$attr) = $propInfo->get qw(Class Name Virtual Access Mutators Attributes);
|
|
49
|
115 (my $field = "${class}_$name") =~ s/::/_/g;
|
|
|
116
|
|
|
117 my $propGlob = $class.'::'.$name;
|
|
|
118
|
|
|
119 no strict 'refs';
|
|
55
|
120 *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field,$attr->{validator});
|
|
49
|
121 *$propGlob = \$field if $isExportField;
|
|
|
122
|
|
|
123 if (ref $mutators) {
|
|
|
124 $propInfo->canGet( $mutators->{get} ? 1 : 0);
|
|
|
125 $propInfo->canSet( $mutators->{set} ? 1 : 0);
|
|
|
126 } else {
|
|
|
127 $propInfo->canGet( ($mutators & prop_get) ? 1 : 0);
|
|
|
128 $propInfo->canSet( ($mutators & prop_set) ? 1 : 0);
|
|
|
129 }
|
|
|
130 }
|
|
|
131
|
|
|
132 sub FieldName {
|
|
|
133 my ($self,$propInfo) = @_;
|
|
|
134
|
|
|
135 my ($class,$name) = $propInfo->get qw(Class Name);
|
|
|
136 (my $field = "${class}_$name") =~ s/::/_/g;
|
|
|
137 return $field;
|
|
|
138 }
|
|
|
139
|
|
|
140 1;
|
