Mercurial > pub > Impl

comparison Lib/IMPL/Class/Property/Direct.pm @ 59:0f3e369553bd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Rewritten property implementation (probably become slower but more flexible) Configuration infrastructure in progress (in the aspect of the lazy activation) Initial concept for the code generator
author wizard
date Tue, 09 Mar 2010 02:50:45 +0300
parents 609b59c9f03c
children b0c068da93ac
comparison
equal deleted inserted replaced
58:a35b60b16a99 59:0f3e369553bd
1 package IMPL::Class::Property::Direct; 1 package IMPL::Class::Property::Direct;
2 use strict; 2 use strict;
3 3
4 use base qw(IMPL::Object::Accessor Exporter); 4 use base qw(IMPL::Object::Accessor IMPL::Class::Property::Base Exporter);
5 our @EXPORT = qw(_direct); 5 our @EXPORT = qw(_direct);
6 6
7 require IMPL::Object::List; 7 require IMPL::Object::List;
8 use IMPL::Class::Property; 8 use IMPL::Class::Property;
9 require IMPL::Exception; 9 require IMPL::Exception;
10 10
11 __PACKAGE__->mk_accessors qw(ExportField); 11 __PACKAGE__->mk_accessors qw(ExportField);
12 12
13 push @IMPL::Class::Property::Base::factoryParams, qw($field);
14
13 sub _direct($) { 15 sub _direct($) {
14 my ($prop_info) = @_; 16 my ($prop_info) = @_;
15 $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) ); 17 $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) );
16 return $prop_info; 18 return $prop_info;
17 } 19 }
18 20
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 21
22 my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; 22 sub GenerateGet {
23 my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; 23 'return ($this->{$field});';
24 my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );'; 24 }
25 my $accessor_get = 'return( $this->{$field} );';
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 );';
46 my $custom_accessor_get = 'unshift @_, $this and goto &$get;';
47 my $custom_accessor_set = 'unshift @_, $this and goto &$set;';
48 25
49 my %accessor_cache; 26 sub GenerateSet {
50 sub mk_acessor { 27 'return ($this->{$field} = $_[0])';
51 my ($virtual,$access,$class,$name,$mutators,$field,$validator) = @_;
52
53 my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set);
54 my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')), $validator ? 1 : 0 ;
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
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
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 } 28 }
95 END 29
96 warn $code; 30 sub GenerateSetList {
97 $factory = eval $code; 31 'return(
98 if (not $factory) { 32 wantarray ?
99 my $err = $@; 33 @{ $this->{$field} = IMPL::Object::List->new(
100 die new IMPL::Exception('Failed to generate the accessor factory',$err); 34 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
101 } 35 )} :
102 $accessor_cache{$key} = $factory; 36 ($this->{$field} = IMPL::Object::List->new(
103 } 37 (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
104 38 ))
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); 39 );';
106 40 }
107 return $factory->($class,$name,$set,$get, $field, $validator); 41
42 sub GenerateGetList {
43 'return(
44 wantarray ?
45 @{ $this->{$field} ?
46 $this->{$field} :
47 ( $this->{$field} = IMPL::Object::List->new() )
48 } :
49 ( $this->{$field} ?
50 $this->{$field} :
51 ( $this->{$field} = IMPL::Object::List->new() )
52 )
53 );';
54 }
55
56 sub RemapFactoryParams {
57 my ($self,$propInfo) = @_;
58
59 return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo);
108 } 60 }
109 61
110 sub Make { 62 sub Make {
111 my ($self,$propInfo) = @_; 63 my ($self,$propInfo) = @_;
112 64
113 my $isExportField = ref $self ? ($self->ExportField || 0) : 0; 65 $self->SUPER::Make($propInfo);
114 my ($class,$name,$virt,$access,$mutators,$attr) = $propInfo->get qw(Class Name Virtual Access Mutators Attributes); 66
115 (my $field = "${class}_$name") =~ s/::/_/g; 67 {
116 68 no strict 'refs';
117 my $propGlob = $class.'::'.$name; 69 if (ref $self and $self->ExportField) {
118 70 my $field = $self->FieldName($propInfo);
119 no strict 'refs'; 71 *{$propInfo->Class.'::'.$propInfo->Name} = \$field;
120 *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field,$attr->{validator}); 72 }
121 *$propGlob = \$field if $isExportField; 73 }
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 } 74 }
131 75
132 sub FieldName { 76 sub FieldName {
133 my ($self,$propInfo) = @_; 77 my ($self,$propInfo) = @_;
134 78