Mercurial > pub > Impl

comparison Lib/IMPL/Class/Property/Direct.pm @ 55:609b59c9f03c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Web application rewrote prop_list implementation to support IMPL::Object::List
author wizard
date Wed, 03 Mar 2010 17:40:18 +0300
parents 15d720913562
children 0f3e369553bd
comparison
equal deleted inserted replaced
54:f4e045e47770 55:609b59c9f03c
2 use strict; 2 use strict;
3 3
4 use base qw(IMPL::Object::Accessor Exporter); 4 use base qw(IMPL::Object::Accessor Exporter);
5 our @EXPORT = qw(_direct); 5 our @EXPORT = qw(_direct);
6 6
7 require IMPL::Object::List;
7 use IMPL::Class::Property; 8 use IMPL::Class::Property;
8 require IMPL::Exception; 9 require IMPL::Exception;
9 10
10 __PACKAGE__->mk_accessors qw(ExportField); 11 __PACKAGE__->mk_accessors qw(ExportField);
11 12
20 21
21 my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; 22 my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;';
22 my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; 23 my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;';
23 my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );'; 24 my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );';
24 my $accessor_get = 'return( $this->{$field} );'; 25 my $accessor_get = 'return( $this->{$field} );';
25 my $list_accessor_set = 'return( @{ ($this->{$field} = IMPL::Object::List->new( ( (@_ == 1 and ref $_[0] eq \'ARRAY\') ? $_[0] : [@_] ) || [] ) } );'; 26 my $list_accessor_set = 'return(
26 my $list_accessor_get = 'return( @{ $this->{$field} ? $this->{$field} : $this->{$field} = IMPL::Object::List->new() } );'; 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 );';
27 my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; 46 my $custom_accessor_get = 'unshift @_, $this and goto &$get;';
28 my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; 47 my $custom_accessor_set = 'unshift @_, $this and goto &$set;';
29 48
30 my %accessor_cache; 49 my %accessor_cache;
31 sub mk_acessor { 50 sub mk_acessor {
32 my ($virtual,$access,$class,$name,$mutators,$field) = @_; 51 my ($virtual,$access,$class,$name,$mutators,$field,$validator) = @_;
33 52
34 my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set); 53 my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set);
35 my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')); 54 my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')), $validator ? 1 : 0 ;
36 my $factory = $accessor_cache{$key}; 55 my $factory = $accessor_cache{$key};
37 if (not $factory) { 56 if (not $factory) {
38 my $code = 57 my $code =
39 <<BEGIN; 58 <<BEGIN;
40 sub { 59 sub {
45 BEGIN 64 BEGIN
46 $code .= <<VCALL if $virtual; 65 $code .= <<VCALL if $virtual;
47 my \$method = \$this->can(\$name); 66 my \$method = \$this->can(\$name);
48 return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class); 67 return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class);
49 VCALL 68 VCALL
50 $code .= "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; 69 $code .= ' 'x8 . "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE;
51 $code .= "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; 70 $code .= ' 'x8 . "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED;
71 $code .= ' 'x8 . '$this->$validator(@_);'."\n" if $validator;
72
52 my ($codeGet,$codeSet); 73 my ($codeGet,$codeSet);
53 if (ref $mutators) { 74 if (ref $mutators) {
54 $codeGet = $get ? $custom_accessor_get : $accessor_get_no; 75 $codeGet = $get ? $custom_accessor_get : $accessor_get_no;
55 $codeSet = $set ? $custom_accessor_set : $accessor_set_no; 76 $codeSet = $set ? $custom_accessor_set : $accessor_set_no;
56 } else { 77 } else {
70 $codeGet 91 $codeGet
71 } 92 }
72 } 93 }
73 } 94 }
74 END 95 END
75 $factory = eval $code or die new IMPL::Exception('Failed to generate the accessor',$@); 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 }
76 $accessor_cache{$key} = $factory; 102 $accessor_cache{$key} = $factory;
77 } 103 }
78 return $factory->($class,$name,$set,$get, $field); 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);
79 } 108 }
80 109
81 sub Make { 110 sub Make {
82 my ($self,$propInfo) = @_; 111 my ($self,$propInfo) = @_;
83 112
84 my $isExportField = ref $self ? ($self->ExportField || 0) : 0; 113 my $isExportField = ref $self ? ($self->ExportField || 0) : 0;
85 my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); 114 my ($class,$name,$virt,$access,$mutators,$attr) = $propInfo->get qw(Class Name Virtual Access Mutators Attributes);
86 (my $field = "${class}_$name") =~ s/::/_/g; 115 (my $field = "${class}_$name") =~ s/::/_/g;
87 116
88 my $propGlob = $class.'::'.$name; 117 my $propGlob = $class.'::'.$name;
89 118
90 no strict 'refs'; 119 no strict 'refs';
91 *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field); 120 *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field,$attr->{validator});
92 *$propGlob = \$field if $isExportField; 121 *$propGlob = \$field if $isExportField;
93 122
94 if (ref $mutators) { 123 if (ref $mutators) {
95 $propInfo->canGet( $mutators->{get} ? 1 : 0); 124 $propInfo->canGet( $mutators->{get} ? 1 : 0);
96 $propInfo->canSet( $mutators->{set} ? 1 : 0); 125 $propInfo->canSet( $mutators->{set} ? 1 : 0);