line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POOF::Properties::Array; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
57426
|
use 5.007; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
163
|
|
4
|
1
|
|
|
1
|
|
7
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
47
|
|
5
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
49
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
6
|
use Carp qw(croak confess); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
99
|
|
8
|
1
|
|
|
1
|
|
11
|
use base qw(POOF::Properties); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
972
|
|
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
15
|
use POOF::DataType; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
56
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '1.0'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
my %DEFINITION; |
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
|
|
89
|
use constant ACCESSLEVEL => |
17
|
|
|
|
|
|
|
{ |
18
|
|
|
|
|
|
|
'Private' => 0, |
19
|
|
|
|
|
|
|
'Protected' => 1, |
20
|
|
|
|
|
|
|
'Public' => 2, |
21
|
1
|
|
|
1
|
|
5
|
}; |
|
1
|
|
|
|
|
4
|
|
22
|
|
|
|
|
|
|
|
23
|
1
|
|
|
1
|
|
82
|
use constant PUBLIC => '@@__POOF::Properties::Public__@@'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
92
|
|
24
|
1
|
|
|
1
|
|
7
|
use constant DUMMY => '@@__POOF::Properties::DUMMY__@@'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3290
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
my $GROUPS; |
27
|
|
|
|
|
|
|
my $REFOBJ; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our $DEBUG = 0; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# CONSTRUCTOR |
32
|
|
|
|
|
|
|
sub TIEARRAY |
33
|
|
|
|
|
|
|
{ |
34
|
1
|
|
|
1
|
|
174
|
my $class = shift; |
35
|
1
|
|
|
|
|
3
|
my $obj = {}; |
36
|
1
|
|
|
|
|
4
|
bless $obj, $class; |
37
|
1
|
|
|
|
|
6
|
$obj->_init(@_); |
38
|
1
|
|
|
|
|
4
|
return $obj; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
#------------------------------------------------------------------------------- |
42
|
|
|
|
|
|
|
# Protected Methods go here |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub _init |
45
|
|
|
|
|
|
|
{ |
46
|
1
|
|
|
1
|
|
3
|
my ($obj,$def,$self,$exceptionHandlerRef,$propertiesRef,$propBackDoor) = @_; |
47
|
|
|
|
|
|
|
|
48
|
1
|
50
|
|
|
|
13
|
$obj->{'self'} = |
49
|
|
|
|
|
|
|
$self |
50
|
|
|
|
|
|
|
? $self |
51
|
|
|
|
|
|
|
: ref($obj); |
52
|
|
|
|
|
|
|
|
53
|
1
|
50
|
|
|
|
7
|
$obj->{'exceptionHandler'} = $exceptionHandlerRef |
54
|
|
|
|
|
|
|
if $exceptionHandlerRef; |
55
|
|
|
|
|
|
|
|
56
|
1
|
|
|
|
|
3
|
$$propertiesRef->{ $obj->{'self'} } = $obj; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# make sure all keys are lower case |
59
|
1
|
|
|
|
|
2
|
%{$obj->{'def'}} = map { lc($_) => $def->{ $_ } } keys %{$def}; |
|
1
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
6
|
|
60
|
|
|
|
|
|
|
|
61
|
1
|
50
|
33
|
|
|
17
|
my $access = |
62
|
|
|
|
|
|
|
exists $obj->{'def'}->{'access'} && defined $obj->{'def'}->{'access'} |
63
|
|
|
|
|
|
|
? $obj->{'def'}->{'access'} |
64
|
|
|
|
|
|
|
: ''; |
65
|
|
|
|
|
|
|
|
66
|
1
|
50
|
|
|
|
9
|
$obj->{'def'}->{'access'} = |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
67
|
|
|
|
|
|
|
$access |
68
|
|
|
|
|
|
|
? exists +ACCESSLEVEL->{ $access } |
69
|
|
|
|
|
|
|
? +ACCESSLEVEL->{ $access } |
70
|
|
|
|
|
|
|
: confess "Unkown access type: $access" |
71
|
|
|
|
|
|
|
: $obj->{'def'}->{'name'} eq DUMMY |
72
|
|
|
|
|
|
|
? +ACCESSLEVEL->{'Private'} |
73
|
|
|
|
|
|
|
: +ACCESSLEVEL->{'Public'}; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
|
76
|
1
|
|
|
|
|
5
|
$obj->CLEAR; |
77
|
|
|
|
|
|
|
|
78
|
1
|
|
|
|
|
2
|
return @_; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub RefObj |
82
|
|
|
|
|
|
|
{ |
83
|
0
|
|
|
0
|
0
|
0
|
my ($obj,$ref) = @_; |
84
|
0
|
|
|
|
|
0
|
$obj->{'___refobj___'} = $ref; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
#------------------------------------------------------------------------------- |
88
|
|
|
|
|
|
|
# property definitions |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub Definition |
91
|
|
|
|
|
|
|
{ |
92
|
0
|
|
|
0
|
0
|
0
|
my $obj = +shift->_enforcement; |
93
|
|
|
|
|
|
|
#---------------------------------- |
94
|
0
|
|
|
|
|
0
|
return $obj->{'def'}; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
#------------------------------------------------------------------------------- |
98
|
|
|
|
|
|
|
# hash functionality bindings |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub CLEAR |
101
|
|
|
|
|
|
|
{ |
102
|
2
|
|
|
2
|
|
13
|
my $obj = +shift->_enforcement; |
103
|
|
|
|
|
|
|
#---------------------------------- |
104
|
2
|
|
|
|
|
9
|
return $obj->{'ARRAY'} = [ ]; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub EXISTS |
108
|
|
|
|
|
|
|
{ |
109
|
1
|
|
|
1
|
|
4
|
my $obj = +shift->_enforcement; |
110
|
|
|
|
|
|
|
#---------------------------------- |
111
|
1
|
|
|
|
|
5
|
return exists $obj->{'ARRAY'}->[ +shift ]; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub FETCH |
115
|
|
|
|
|
|
|
{ |
116
|
4
|
|
|
4
|
|
28
|
my $obj = +shift->_enforcement; |
117
|
|
|
|
|
|
|
#---------------------------------- |
118
|
4
|
|
|
|
|
6
|
my ($i) = @_; |
119
|
0
|
|
|
|
|
0
|
$obj->STORE |
120
|
|
|
|
|
|
|
( |
121
|
|
|
|
|
|
|
$i,$obj->{'def'}->{'otype'}->new |
122
|
|
|
|
|
|
|
( |
123
|
4
|
50
|
|
|
|
20
|
%{$obj->{'def'}->{'args'}} |
124
|
|
|
|
|
|
|
) |
125
|
|
|
|
|
|
|
) unless(exists $obj->{'ARRAY'}->[$i]); |
126
|
4
|
|
|
|
|
15
|
return $obj->{'ARRAY'}->[$i]; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub FETCHSIZE |
130
|
|
|
|
|
|
|
{ |
131
|
9
|
|
|
9
|
|
3627
|
my $obj = +shift->_enforcement; |
132
|
|
|
|
|
|
|
#---------------------------------- |
133
|
9
|
|
|
|
|
19
|
return scalar @{$obj->{'ARRAY'}}; |
|
9
|
|
|
|
|
37
|
|
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub DELETE |
137
|
|
|
|
|
|
|
{ |
138
|
1
|
|
|
1
|
|
6
|
my $obj = +shift->_enforcement; |
139
|
|
|
|
|
|
|
#---------------------------------- |
140
|
1
|
|
|
|
|
5
|
return delete $obj->{'ARRAY'}->[ +shift ]; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub STORE |
144
|
|
|
|
|
|
|
{ |
145
|
5
|
|
|
5
|
|
12
|
my $obj = +shift->_enforcement; |
146
|
|
|
|
|
|
|
#---------------------------------- |
147
|
5
|
|
|
|
|
8
|
my ($i,$v) = @_; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# enforce maxsize |
150
|
5
|
50
|
33
|
|
|
39
|
if (defined $obj->{'def'}->{'maxsize'} && $obj->{'def'}->{'maxsize'}) |
151
|
|
|
|
|
|
|
{ |
152
|
0
|
0
|
|
|
|
0
|
if ($i + 1 > $obj->{'def'}->{'maxsize'}) |
153
|
|
|
|
|
|
|
{ |
154
|
|
|
|
|
|
|
# generate error |
155
|
0
|
0
|
|
|
|
0
|
&{$obj->{'exceptionHandler'}} |
|
0
|
|
|
|
|
0
|
|
156
|
|
|
|
|
|
|
( |
157
|
|
|
|
|
|
|
$obj->{'___refobj___'}, |
158
|
|
|
|
|
|
|
$obj->{'def'}->{'name'}, |
159
|
|
|
|
|
|
|
{ |
160
|
|
|
|
|
|
|
'code' => 133, |
161
|
|
|
|
|
|
|
'description' => "maxsize test failed", |
162
|
|
|
|
|
|
|
'value' => $v |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
) if defined $obj->{'exceptionHandler'}; |
165
|
0
|
|
|
|
|
0
|
return; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# only allow store if $v is of the right class |
170
|
5
|
100
|
|
|
|
22
|
unless ($obj->_relationship($v,$obj->{'def'}->{'otype'}) =~ /^(?:self|child)$/o) |
171
|
|
|
|
|
|
|
{ |
172
|
|
|
|
|
|
|
# generate error |
173
|
1
|
50
|
|
|
|
15
|
&{$obj->{'exceptionHandler'}} |
|
1
|
|
|
|
|
7
|
|
174
|
|
|
|
|
|
|
( |
175
|
|
|
|
|
|
|
$obj->{'___refobj___'}, |
176
|
|
|
|
|
|
|
$obj->{'def'}->{'name'}, |
177
|
|
|
|
|
|
|
{ |
178
|
|
|
|
|
|
|
'code' => 173, |
179
|
|
|
|
|
|
|
'description' => "element index $i: is not of a valid type", |
180
|
|
|
|
|
|
|
'value' => $v |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
) if defined $obj->{'exceptionHandler'}; |
183
|
1
|
|
|
|
|
80
|
return; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
4
|
|
|
|
|
27
|
return $obj->{'ARRAY'}->[ $i ] = $v; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub STORESIZE |
190
|
|
|
|
|
|
|
{ |
191
|
1
|
|
|
1
|
|
2
|
my $obj = +shift->_enforcement; |
192
|
|
|
|
|
|
|
#---------------------------------- |
193
|
1
|
|
|
|
|
3
|
my ($newsize) = @_; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# enforce maxsize |
196
|
1
|
50
|
33
|
|
|
6
|
if (defined $obj->{'def'}->{'maxsize'} && $obj->{'def'}->{'maxsize'}) |
197
|
|
|
|
|
|
|
{ |
198
|
0
|
0
|
|
|
|
0
|
if ($newsize + 1 > $obj->{'def'}->{'maxsize'}) |
199
|
|
|
|
|
|
|
{ |
200
|
|
|
|
|
|
|
# generate error |
201
|
0
|
0
|
|
|
|
0
|
&{$obj->{'exceptionHandler'}} |
|
0
|
|
|
|
|
0
|
|
202
|
|
|
|
|
|
|
( |
203
|
|
|
|
|
|
|
$obj->{'___refobj___'}, |
204
|
|
|
|
|
|
|
$obj->{'def'}->{'name'}, |
205
|
|
|
|
|
|
|
{ |
206
|
|
|
|
|
|
|
'code' => 133, |
207
|
|
|
|
|
|
|
'description' => "maxsize test failed", |
208
|
|
|
|
|
|
|
'value' => '' |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
) if defined $obj->{'exceptionHandler'}; |
211
|
0
|
|
|
|
|
0
|
return; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
|
216
|
1
|
|
|
|
|
1
|
my $diff = $newsize - @{$obj->{'ARRAY'}}; |
|
1
|
|
|
|
|
3
|
|
217
|
|
|
|
|
|
|
|
218
|
1
|
50
|
|
|
|
4
|
unless ($diff == 0) |
219
|
|
|
|
|
|
|
{ |
220
|
|
|
|
|
|
|
return |
221
|
1
|
|
|
|
|
11
|
$diff > 0 |
222
|
0
|
|
|
|
|
0
|
? $obj->{'ARRAY'}->[ $diff .. $newsize ] = map { undef } ($diff .. $newsize) |
223
|
1
|
50
|
|
|
|
5
|
: map { $obj->POP } ( 0 .. (scalar(@{$obj->{'ARRAY'}}) - $newsize) - 2 ); |
|
0
|
|
|
|
|
0
|
|
224
|
|
|
|
|
|
|
} |
225
|
0
|
|
|
|
|
0
|
return; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
sub PUSH |
229
|
|
|
|
|
|
|
{ |
230
|
0
|
|
|
0
|
|
0
|
my $obj = +shift->_enforcement; |
231
|
|
|
|
|
|
|
#---------------------------------- |
232
|
0
|
|
|
|
|
0
|
return push(@{$obj->{'ARRAY'}},@_); |
|
0
|
|
|
|
|
0
|
|
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub POP |
236
|
|
|
|
|
|
|
{ |
237
|
0
|
|
|
0
|
|
0
|
my $obj = +shift->_enforcement; |
238
|
|
|
|
|
|
|
#---------------------------------- |
239
|
0
|
|
|
|
|
0
|
return pop @{+shift->_enforcement->{'ARRAY'}}; |
|
0
|
|
|
|
|
0
|
|
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub SHIFT |
243
|
|
|
|
|
|
|
{ |
244
|
0
|
|
|
0
|
|
0
|
my $obj = +shift->_enforcement; |
245
|
|
|
|
|
|
|
#---------------------------------- |
246
|
0
|
|
|
|
|
0
|
return shift @{$obj->{'ARRAY'}}; |
|
0
|
|
|
|
|
0
|
|
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
sub UNSHIFT |
250
|
|
|
|
|
|
|
{ |
251
|
0
|
|
|
0
|
|
0
|
my $obj = +shift->_enforcement; |
252
|
|
|
|
|
|
|
#---------------------------------- |
253
|
0
|
|
|
|
|
0
|
my @list = @_; |
254
|
0
|
|
|
|
|
0
|
my $size = scalar @list; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# make room for our list |
257
|
0
|
|
|
|
|
0
|
@{$obj->{'ARRAY'}}[ $size .. $#{$obj->{'ARRAY'}} + $size ] = @{$obj->{'ARRAY'}}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
return map { $obj->STORE($_,$list[$_]) } (0 .. $#list); |
|
0
|
|
|
|
|
0
|
|
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
sub SPLICE |
263
|
|
|
|
|
|
|
{ |
264
|
0
|
|
|
0
|
|
0
|
my $obj = +shift->_enforcement; |
265
|
|
|
|
|
|
|
#---------------------------------- |
266
|
0
|
|
0
|
|
|
0
|
my $offset = shift || 0; |
267
|
0
|
|
0
|
|
|
0
|
my $length = shift || $obj->FETCHSIZE - $offset; |
268
|
0
|
|
|
|
|
0
|
my @list = (); |
269
|
|
|
|
|
|
|
|
270
|
0
|
0
|
|
|
|
0
|
if ( @_ ) |
271
|
|
|
|
|
|
|
{ |
272
|
0
|
|
|
|
|
0
|
tie @list, __PACKAGE__; |
273
|
0
|
|
|
|
|
0
|
@list = @_; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
0
|
return splice @{$obj->{'ARRAY'}}, $offset, $length, @list; |
|
0
|
|
|
|
|
0
|
|
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub EXTEND |
280
|
|
|
|
|
|
|
{ |
281
|
1
|
|
|
1
|
|
3
|
my $obj = +shift->_enforcement; |
282
|
|
|
|
|
|
|
#---------------------------------- |
283
|
1
|
|
|
|
|
4
|
return $obj->STORESIZE( +shift ); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
#------------------------------------------------------------------------------- |
287
|
|
|
|
|
|
|
# private Methods |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub Trace |
290
|
|
|
|
|
|
|
{ |
291
|
0
|
|
|
0
|
0
|
0
|
my $obj = shift; |
292
|
0
|
|
|
|
|
0
|
my %caller; |
293
|
0
|
|
|
|
|
0
|
@caller{ qw( |
294
|
|
|
|
|
|
|
0-package |
295
|
|
|
|
|
|
|
1-filename |
296
|
|
|
|
|
|
|
2-line |
297
|
|
|
|
|
|
|
3-subr |
298
|
|
|
|
|
|
|
4-has_args |
299
|
|
|
|
|
|
|
5-wantarray |
300
|
|
|
|
|
|
|
6-evaltext |
301
|
|
|
|
|
|
|
7-is_required |
302
|
|
|
|
|
|
|
8-hints |
303
|
|
|
|
|
|
|
9-bitmask |
304
|
|
|
|
|
|
|
) } = caller(1); |
305
|
|
|
|
|
|
|
|
306
|
0
|
|
|
|
|
0
|
warn "$caller{'3-subr'}\n\t\tcalled from line [ $caller{'2-line'} ] in ($caller{'0-package'}) $caller{'1-filename'}\n"; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
sub _dumpAccessContext |
310
|
|
|
|
|
|
|
{ |
311
|
0
|
|
|
0
|
|
0
|
my $obj = shift; |
312
|
0
|
|
|
|
|
0
|
my $start = 0; |
313
|
0
|
|
|
|
|
0
|
my %caller; |
314
|
|
|
|
|
|
|
|
315
|
0
|
|
|
|
|
0
|
for($start .. 5) |
316
|
|
|
|
|
|
|
{ |
317
|
0
|
|
|
|
|
0
|
@caller{ qw( |
318
|
|
|
|
|
|
|
0-package |
319
|
|
|
|
|
|
|
1-filename |
320
|
|
|
|
|
|
|
2-line |
321
|
|
|
|
|
|
|
3-subr |
322
|
|
|
|
|
|
|
4-has_args |
323
|
|
|
|
|
|
|
5-wantarray |
324
|
|
|
|
|
|
|
6-evaltext |
325
|
|
|
|
|
|
|
7-is_required |
326
|
|
|
|
|
|
|
8-hints |
327
|
|
|
|
|
|
|
9-bitmask |
328
|
|
|
|
|
|
|
) } = caller($_); |
329
|
|
|
|
|
|
|
|
330
|
0
|
0
|
|
|
|
0
|
last unless defined $caller{'0-package'}; |
331
|
|
|
|
|
|
|
|
332
|
0
|
|
|
|
|
0
|
warn "\ncaller $_\n" . "-"x50 . "\n"; |
333
|
0
|
|
|
|
|
0
|
$obj->_dumpCaller(\%caller); |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub _dumpCaller |
338
|
|
|
|
|
|
|
{ |
339
|
0
|
|
|
0
|
|
0
|
my $obj = shift; |
340
|
0
|
|
|
|
|
0
|
my $caller = shift; |
341
|
0
|
0
|
|
|
|
0
|
warn "\n" . ( |
342
|
|
|
|
|
|
|
join "\n", map |
343
|
|
|
|
|
|
|
{ |
344
|
0
|
|
|
|
|
0
|
sprintf "\t%-15s = %-15s", $_, |
345
|
|
|
|
|
|
|
defined $caller->{$_} |
346
|
|
|
|
|
|
|
? $caller->{$_} |
347
|
|
|
|
|
|
|
: 'undef' |
348
|
|
|
|
|
|
|
} sort keys %$caller) . "\n\n"; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
sub _callerContext |
352
|
|
|
|
|
|
|
{ |
353
|
24
|
|
|
24
|
|
37
|
my ($obj,$level) = @_; |
354
|
24
|
|
50
|
|
|
174
|
my $caller = (caller($level || 2))[0]; |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# ugly hack that needs to be fix |
357
|
24
|
50
|
|
|
|
72
|
defined $caller && $caller =~ s/POOF::TEMPORARYNAMESPACE//o; |
358
|
|
|
|
|
|
|
|
359
|
24
|
|
|
|
|
61
|
my $relationship = $obj->_relationship($caller,$obj->{'self'}); |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
return |
362
|
24
|
50
|
|
|
|
118
|
$relationship eq 'self' |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
363
|
|
|
|
|
|
|
? 0 # 'private' |
364
|
|
|
|
|
|
|
: $relationship eq 'child' |
365
|
|
|
|
|
|
|
? 1 # 'protected' |
366
|
|
|
|
|
|
|
: $relationship eq 'parent' |
367
|
|
|
|
|
|
|
? -1 # parent has not visibility into children |
368
|
|
|
|
|
|
|
: 2 # 'public'; |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub _relationship |
373
|
|
|
|
|
|
|
{ |
374
|
29
|
|
|
29
|
|
34
|
my $obj = shift; |
375
|
29
|
100
|
|
|
|
45
|
my ($class1,$class2) = map { $_ ? ref $_ ? ref $_ : $_ : '' } @_; |
|
58
|
50
|
|
|
|
183
|
|
376
|
|
|
|
|
|
|
|
377
|
29
|
100
|
|
|
|
92
|
return 'self' if $class1 eq $class2; |
378
|
|
|
|
|
|
|
|
379
|
13
|
|
|
|
|
39
|
my %family1 = map { $_ => 1 } Class::ISA::super_path( $class1 ); |
|
22
|
|
|
|
|
538
|
|
380
|
13
|
|
|
|
|
65
|
my %family2 = map { $_ => 1 } Class::ISA::super_path( $class2 ); |
|
1
|
|
|
|
|
41
|
|
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
return |
383
|
13
|
50
|
|
|
|
252
|
exists $family1{ $class2 } |
|
|
50
|
|
|
|
|
|
384
|
|
|
|
|
|
|
? 'child' |
385
|
|
|
|
|
|
|
: exists $family2{ $class1 } |
386
|
|
|
|
|
|
|
? 'parent' |
387
|
|
|
|
|
|
|
: 'unrelated'; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
sub _classOrChild |
391
|
|
|
|
|
|
|
{ |
392
|
0
|
|
|
0
|
|
0
|
my ($obj,$level) = @_; |
393
|
0
|
|
0
|
|
|
0
|
my $caller = (caller($level || 2))[0]; |
394
|
|
|
|
|
|
|
|
395
|
0
|
|
|
|
|
0
|
my $relationship = $obj->_relationship($caller,$obj); |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
return |
398
|
0
|
0
|
|
|
|
0
|
$relationship eq 'self' |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
399
|
|
|
|
|
|
|
? 1 # 'private' |
400
|
|
|
|
|
|
|
: $relationship eq 'child' |
401
|
|
|
|
|
|
|
? 1 # 'protected' |
402
|
|
|
|
|
|
|
: $relationship eq 'parent' |
403
|
|
|
|
|
|
|
? 1 # parent has visibility into children |
404
|
|
|
|
|
|
|
: 0 # 'public'; |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub _enforcement |
409
|
|
|
|
|
|
|
{ |
410
|
24
|
|
|
24
|
|
41
|
my $obj = shift; |
411
|
|
|
|
|
|
|
# enforce encapsulation |
412
|
24
|
50
|
33
|
|
|
72
|
confess "Access violation" |
413
|
|
|
|
|
|
|
unless $obj->{'def'}->{'access'} >= $obj->_callerContext(@_) || $obj->_classOrChild(@_); |
414
|
24
|
|
|
|
|
41
|
return $obj; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
1; |
419
|
|
|
|
|
|
|
__END__ |