File Coverage

blib/lib/Tie/Array/Cavity.pm
Criterion Covered Total %
statement 54 105 51.4
branch 0 26 0.0
condition 0 6 0.0
subroutine 18 36 50.0
pod 6 6 100.0
total 78 179 43.5


line stmt bran cond sub pod time code
1             package Tie::Array::Cavity;
2              
3 1     1   26535 use 5.006;
  1         4  
  1         51  
4 1     1   5 use strict;
  1         2  
  1         31  
5 1     1   5 use warnings;
  1         5  
  1         29  
6 1     1   6872 use Tie::Array;
  1         1597  
  1         90  
7              
8             our $VERSION = '0.02';
9              
10              
11             sub TIEARRAY
12             {
13 0     0     my ( $class ) = @_;
14 0   0       bless {
      0        
15             _step => $_[1] || 1,
16             _base => $_[2] || 0,
17             _data => [],
18             }, $class;
19             }
20              
21              
22             sub STORE
23             {
24 1     1   4002 use integer;
  1         16  
  1         7  
25 0     0     my $i = ( $_[1] - $_[0]->{ _base } ) / $_[0]->{ _step };
26 0 0         $i = 0 if ( $i < 0 );
27 1     1   158 no integer;
  1         2  
  1         5  
28 0           $_[0]->{ _data }->[$i] = $_[2];
29             }
30              
31              
32              
33             sub STORESIZE
34             {
35 0     0     $#{ $_[0] } = $_[1] - 1;
  0            
36             }
37              
38              
39             sub FETCHSIZE
40             {
41 0     0     scalar @{ $_[0]->{ _data } };
  0            
42             }
43              
44              
45             sub FETCHCAVITY
46             {
47 1     1   138 use integer;
  1         2  
  1         4  
48 0     0 1   my $i = ( $_[1] - $_[0]->{ _base } ) / $_[0]->{ _step };
49 0 0         $i = 0 if ( $i < 0 );
50 1     1   77 no integer;
  1         3  
  1         4  
51 0           $_[0]->{ _data }->[$i];
52             }
53              
54              
55              
56             sub FETCHKEY
57             {
58 1     1   161 use integer;
  1         2  
  1         5  
59 0     0 1   my $i = ( $_[1] - $_[0]->{ _base } ) / $_[0]->{ _step };
60 0 0         $i = 0 if ( $i < 0 );
61 1     1   230 no integer;
  1         2  
  1         4  
62 0           ( $i * $_[0]->{ _step } ) + $_[0]->{ _base };
63             }
64              
65              
66             sub FETCHKEYCAVITY
67             {
68 1     1   73 use integer;
  1         2  
  1         5  
69 0   0 0 1   my $i = ( ($_[1] || 0 ) * $_[0]->{ _step } ) + $_[0]->{ _base };
70 0 0         $i = 0 if ( $i < 0 );
71 1     1   60 no integer;
  1         3  
  1         4  
72 0           $i;
73             }
74              
75              
76             sub FETCH
77             {
78 0     0     $_[0]->{ _data }->[ $_[1] ];
79             }
80              
81              
82              
83             sub POP
84             {
85 0     0     pop @{ $_[0]->{ _data } };
  0            
86             }
87              
88              
89             sub SHIFT
90             {
91 0     0     shift @{ $_[0]->{ _data } };
  0            
92             }
93              
94              
95              
96             sub PUSH
97             {
98 0     0     push @{ $_[0]->{ _data } }, $_[1];
  0            
99             }
100              
101              
102              
103              
104             sub UNSHIFT
105             {
106 0     0     unshift @{ $_[0]->{ _data } }, $_[1];
  0            
107             }
108              
109              
110             sub EXISTSCAVITY
111             {
112 1     1   221 use integer;
  1         3  
  1         4  
113 0     0 1   my $i = ( $_[1] - $_[0]->{ _base } ) / $_[0]->{ _step };
114 0 0         $i = 0 if ( $i < 0 );
115 1     1   70 no integer;
  1         3  
  1         3  
116 0           exists $_[0]->{ _data }->[$i];
117             }
118              
119              
120             sub EXISTS
121             {
122 0     0     exists $_[0]->{ _data }->[$_[1]];
123             }
124              
125              
126             sub DELETECAVITY
127             {
128 1     1   88 use integer;
  1         2  
  1         5  
129 0     0 1   my $i = ( $_[1] - $_[0]->{ _base } ) / $_[0]->{ _step };
130 0 0         $i = 0 if ( $i < 0 );
131 1     1   61 no integer;
  1         2  
  1         4  
132 0           delete $_[0]->{ _data }->[$i];
133             }
134              
135              
136             sub DELETE
137             {
138 0     0     delete $_[0]->{ _data }->[$_[1]];
139             }
140              
141              
142              
143             sub SPLICECAVITY
144             {
145 0     0 1   my $self = shift;
146 0 0         my $offset = @_ ? shift : 0;
147 0           my $s = $self->{ _step };
148 0           my $b = $self->{ _base };
149 1     1   381 use integer;
  1         3  
  1         5  
150 0           my $off = ( $offset - $b ) / $s;
151 0 0         $off = 0 if ( $off < 0 );
152 0           my $sz = $self->FETCHSIZE;
153 0 0         $off += $sz if $off < 0;
154 0 0         my $len = @_ ? shift : $sz - $off;
155 1     1   82 no integer;
  1         2  
  1         5  
156 0           return splice( $self->{ _data }, $off, $len, @_ );
157              
158             }
159              
160              
161             sub SPLICE
162             {
163 0     0     my $self = shift;
164 0 0         my $offset = @_ ? shift : 0;
165 0           my $sz = $self->FETCHSIZE;
166 0 0         $offset += $sz if $offset < 0;
167 0 0         my $len = @_ ? shift : $sz - $offset;
168 0           return splice( $self->{ _data }, $offset, $len, @_ );
169             }
170              
171              
172              
173             1; # End of Tie::Array::Cavity
174              
175             __END__