Mercurial > pub > Impl
annotate Lib/IMPL/Object/Abstract.pm @ 393:69a1f1508696
minor security refactoring
| author | cin |
|---|---|
| date | Fri, 14 Feb 2014 16:41:12 +0400 |
| parents | 82b6c967bcf1 |
| children |
| rev | line source |
|---|---|
| 49 | 1 package IMPL::Object::Abstract; |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 166 | 5 use parent qw(IMPL::Class::Meta); |
| 364 | 6 use Carp qw(croak); |
| 49 | 7 |
| 8 our $MemoryLeakProtection; | |
| 9 my $Cleanup = 0; | |
| 10 | |
| 11 my %cacheCTOR; | |
| 12 | |
| 13 my $t = 0; | |
| 14 sub cache_ctor { | |
| 15 my $class = shift; | |
| 16 | |
| 17 no strict 'refs'; | |
| 18 my @sequence; | |
| 19 | |
| 20 my $refCTORS = *{"${class}::CTOR"}{HASH}; | |
| 21 | |
| 22 foreach my $super ( @{"${class}::ISA"} ) { | |
| 194 | 23 my $superSequence = $cacheCTOR{$super} || cache_ctor($super); |
| 24 | |
| 25 my $mapper = $refCTORS ? $refCTORS->{$super} : undef; | |
| 26 if (ref $mapper eq 'CODE') { | |
| 27 if ($mapper == *_pass_through_mapper{CODE}) { | |
| 28 push @sequence,@$superSequence; | |
| 29 } else { | |
| 30 push @sequence, sub { | |
| 31 my $this = shift; | |
| 32 $this->$_($mapper->(@_)) foreach @$superSequence; | |
| 33 } if @$superSequence; | |
| 34 } | |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
194
diff
changeset
|
35 } elsif ($mapper and not ref $mapper and $mapper eq '@_') { |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
194
diff
changeset
|
36 push @sequence,@$superSequence; |
| 194 | 37 } else { |
| 38 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; | |
| 39 push @sequence, sub { | |
| 40 my $this = shift; | |
| 41 $this->$_() foreach @$superSequence; | |
| 42 } if @$superSequence; | |
| 43 } | |
| 49 | 44 } |
| 45 | |
| 46 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; | |
| 47 | |
| 48 $cacheCTOR{$class} = \@sequence; | |
| 49 return \@sequence; | |
| 50 } | |
| 51 | |
| 90 | 52 sub dump_ctor { |
| 194 | 53 my ($self) = @_; |
| 54 $self = ref $self || $self; | |
| 55 | |
| 56 warn "dumping $self .ctor"; | |
| 57 warn "$_" foreach @{$cacheCTOR{$self}||[]}; | |
| 90 | 58 } |
| 59 | |
| 49 | 60 sub callCTOR { |
| 61 my $self = shift; | |
| 62 my $class = ref $self; | |
| 63 | |
| 64 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; | |
| 65 } | |
| 66 | |
|
273
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
67 sub _init_dtor { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
68 my ($class) = @_; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
69 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
70 no strict 'refs'; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
71 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
72 # avoid warnings for classes without destructors |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
73 no warnings 'once'; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
74 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
75 my @dtors; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
76 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
77 my @hierarchy = ($class); |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
78 my %visited; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
79 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
80 while(my $subclass = shift @hierarchy) { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
81 if(*{"${subclass}::DTOR"}{CODE}) { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
82 push @dtors, *{"${subclass}::DTOR"}{CODE}; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
83 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
84 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
85 push @hierarchy, @{"${subclass}::ISA"}; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
86 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
87 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
88 if (@dtors) { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
89 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
90 return *{"${class}::callDTOR"} = sub { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
91 my ($self) = @_; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
92 my $selfClass = ref $self; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
93 if ($selfClass ne $class) { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
94 goto &{$selfClass->_init_dtor()}; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
95 } else { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
96 map $_->($self), @dtors; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
97 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
98 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
99 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
100 } else { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
101 return *{"${class}::callDTOR"} = sub { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
102 my $self = ref $_[0]; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
103 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
104 goto &{$self->_init_dtor()} unless $self eq $class; |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
105 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
106 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
107 } |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
108 |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
109 __PACKAGE__->_init_dtor(); |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
110 |
| 49 | 111 sub toString { |
| 112 my $self = shift; | |
| 113 | |
| 114 return (ref $self || $self); | |
| 115 } | |
| 116 | |
| 280 | 117 sub _typeof { |
| 194 | 118 ref $_[0] || $_[0]; |
| 93 | 119 } |
| 120 | |
| 49 | 121 sub isDisposed { |
| 122 0; | |
| 123 } | |
| 124 | |
|
273
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
125 sub DESTROY { |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
126 shift->callDTOR(); |
|
ad93c9f4dd93
+Added support for destructors, (special method named DTOR)
sergey
parents:
197
diff
changeset
|
127 } |
| 49 | 128 |
| 129 sub END { | |
| 130 $Cleanup = 1; | |
| 131 } | |
| 132 | |
| 174 | 133 sub _pass_through_mapper { |
| 49 | 134 @_; |
| 135 } | |
| 136 | |
| 137 sub PassArgs { | |
| 174 | 138 \&_pass_through_mapper; |
| 49 | 139 } |
| 140 | |
| 141 sub PassThroughArgs { | |
| 142 my $class = shift; | |
| 143 $class = ref $class || $class; | |
| 144 no strict 'refs'; | |
| 145 no warnings 'once'; | |
| 174 | 146 ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"}; |
| 49 | 147 } |
| 148 | |
| 149 package self; | |
| 150 | |
| 151 our $AUTOLOAD; | |
| 152 sub AUTOLOAD { | |
|
339
97628101b765
refactoring: application now holds a security object factory rather than a security object
cin
parents:
280
diff
changeset
|
153 goto &{caller(). substr $AUTOLOAD,4}; |
| 49 | 154 } |
| 155 | |
| 156 package supercall; | |
| 157 | |
| 158 our $AUTOLOAD; | |
| 159 sub AUTOLOAD { | |
| 160 my $sub; | |
|
339
97628101b765
refactoring: application now holds a security object factory rather than a security object
cin
parents:
280
diff
changeset
|
161 my $methodName = substr $AUTOLOAD,9; |
| 49 | 162 no strict 'refs'; |
| 163 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; | |
| 164 } | |
| 165 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
166 1; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
167 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
168 __END__ |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
169 |
| 49 | 170 =pod |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
171 =head1 SYNOPSIS |
| 49 | 172 |
| 173 package MyBaseObject; | |
| 166 | 174 use parent qw(IMPL::Object::Abstract); |
| 49 | 175 |
| 176 sub new { | |
| 177 # own implementation of the new opeator | |
| 178 } | |
| 179 | |
| 180 sub surrogate { | |
| 181 # own implementation of the surrogate operator | |
| 182 } | |
| 183 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
184 =head1 DESCRIPTION |
| 49 | 185 |
| 180 | 186 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов |
| 187 создания экземпляров. | |
|
276
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
273
diff
changeset
|
188 |
| 49 | 189 =cut |