File Coverage

blib/lib/POOF/Properties/Array.pm
Criterion Covered Total %
statement 92 155 59.3
branch 26 66 39.3
condition 5 21 23.8
subroutine 22 33 66.6
pod 0 3 0.0
total 145 278 52.1


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__