File Coverage

blib/lib/Apache/ASP/State.pm
Criterion Covered Total %
statement 164 201 81.5
branch 57 90 63.3
condition 13 24 54.1
subroutine 26 30 86.6
pod 0 15 0.0
total 260 360 72.2


line stmt bran cond sub pod time code
1             package Apache::ASP::State;
2              
3 14     14   14820 use MLDBM;
  14         67624  
  14         106  
4 14     14   18398 use MLDBM::Sync 0.25;
  14         8275481  
  14         591  
5 14     14   159 use MLDBM::Sync::SDBM_File;
  14         30  
  14         617  
6 14     14   87 use SDBM_File;
  14         27  
  14         431  
7 14     14   75 use Data::Dumper;
  14         25  
  14         605  
8              
9 14     14   74 use strict;
  14         28  
  14         542  
10 14     14   67 no strict qw(refs);
  14         28  
  14         370  
11 14     14   82 use vars qw(%DB %CACHE $DefaultGroupIdLength);
  14         27  
  14         1013  
12 14     14   75 use Fcntl qw(:flock O_RDWR O_CREAT);
  14         41  
  14         35431  
13             $DefaultGroupIdLength = 2;
14              
15             # Database formats supports and their underlying extensions
16             %DB = (
17             SDBM_File => ['.pag', '.dir'],
18             DB_File => [''],
19             'MLDBM::Sync::SDBM_File' => ['.pag', '.dir'],
20             GDBM_File => [''],
21             'Tie::TextDir' => [''],
22             );
23              
24             # About locking, we use a separate lock file from the SDBM files
25             # generated because locking directly on the SDBM files occasionally
26             # results in sdbm store errors. This is less efficient, than locking
27             # to the db file directly, but having a separate lock file works for now.
28             #
29             # If there is no $group given, then the $group will be extracted from
30             # the $id as the first 2 letters of that group.
31             #
32             # If the group and the id are the same length, then what was passed
33             # was just a group id, and the object is being created for informational
34             # purposes only. So, we don't create a lock file in this case, as this
35             # is not a real State object
36             #
37             sub new {
38 199     199 0 411 my($asp, $id, $group) = @_;
39              
40 199 50       780 if($id) {
41 199         414 $id =~ tr///;
42             } else {
43 0         0 $asp->Error("no id: $id passed into new State");
44 0         0 return;
45             }
46              
47             # default group is first 2 characters of id, simple hashing
48 199 100       417 if($group) {
49 57         199 $group =~ tr///;
50             } else {
51 142         459 $group = substr($id, 0, $DefaultGroupIdLength)
52             }
53              
54 199 50       477 unless($group) {
55 0         0 $asp->Error("no group defined for id $id");
56 0         0 return;
57             }
58              
59 199         400 my $state_dir = $asp->{state_dir};
60 199         432 my $group_dir = $state_dir.'/'.$group;
61 199         473 my $lock_file = $group_dir.'/'.$id.'.lock';
62 199         396 my $file = $group_dir.'/'.$id;
63              
64             # we only need SDBM_File for internal, and its faster so use it
65 199         232 my($state_db, $state_serializer);
66 199 100 100     1712 if($id eq 'internal') {
    100          
67 28         56 $state_db = $Apache::ASP::DefaultStateDB;
68 28         50 $state_serializer = $Apache::ASP::DefaultStateSerializer;
69             } elsif($asp->{Internal} && (length($id) > $DefaultGroupIdLength)) {
70             # don't get data for dummy group id sessions
71 96         207 my $internal = $asp->{Internal};
72 96         439 my $idata = $internal->{$id};
73 96 50 33     502 if(! $idata->{state_db} || ! $idata->{state_serializer}) {
74 96   33     721 $state_db = $idata->{state_db} || $asp->{state_db} || $Apache::ASP::DefaultStateDB;
75 96   33     595 $state_serializer = $idata->{state_serializer} ||
76             $asp->{state_serializer} || $Apache::ASP::DefaultStateSerializer;
77            
78             # INIT StateDB && StateSerializer if hitting for the first time
79             # only if real id like a session id or application
80 96 50       272 if(length($id) > $DefaultGroupIdLength) {
81 96         134 my $diff = 0;
82 96 50 33     437 if(($idata->{state_db} || $Apache::ASP::DefaultStateDB) ne $state_db) {
83 0         0 $idata->{state_db} = $state_db;
84 0         0 $diff = 1;
85             }
86 96 50 33     388 if(($idata->{state_serializer} || $Apache::ASP::DefaultStateSerializer) ne $state_serializer) {
87 0         0 $idata->{state_serializer} = $state_serializer;
88 0         0 $diff = 1;
89             }
90              
91 96 50       456 if($diff) {
92 0 0       0 $asp->{dbg} && $asp->Debug("setting internal data for state $id", $idata);
93 0         0 $internal->{$id} = $idata;
94             }
95             }
96             } else {
97             # this state has already been created
98 0         0 $state_db = $idata->{state_db};
99 0         0 $state_serializer = $idata->{state_serializer};
100             }
101             } else {
102             # cache layer doesn't need internal
103 75         217 ($state_db, $state_serializer) = ($asp->{state_db}, $asp->{state_serializer});
104             }
105              
106 199         1951 my $self =
107             bless {
108             asp=>$asp,
109             dbm => undef,
110             'dir' => $group_dir,
111             id => $id,
112             file => $file,
113             group => $group,
114             group_dir => $group_dir,
115             reads => 0,
116             state_dir => $state_dir,
117             writes => 0,
118             };
119              
120             # short circuit before expensive directory tests for group stub
121 199 100       553 if ($group eq $id) {
122 74         381 return $self;
123             }
124              
125 125 50       555 if($asp->config('StateAllWrite')) {
    50          
126 0 0       0 $asp->{dbg} and $asp->{state_all_write} = 1;
127 0         0 $self->{dir_perms} = 0777;
128 0         0 $self->{file_perms} = 0666;
129             } elsif($asp->config('StateGroupWrite')) {
130 0 0       0 $asp->{dbg} and $asp->{state_group_write} = 1;
131 0         0 $self->{dir_perms} = 0770;
132 0         0 $self->{file_perms} = 0660;
133             } else {
134 125         475 $self->{dir_perms} = 0750;
135 125         243 $self->{file_perms} = 0640;
136             }
137              
138             # push(@{$self->{'ext'}}, @{$DB{$self->{state_db}}});
139             # $self->{asp}->Debug("db ext: ".join(",", @{$self->{'ext'}}));
140              
141             # create state directories
142 125         183 my @create_dirs;
143 125 100       2093 unless(-d $state_dir) {
144 2         6 push(@create_dirs, $state_dir);
145             }
146             # create group directory
147 125 100       7767 unless(-d $group_dir) {
148 13         45 push(@create_dirs, $group_dir);
149             }
150 125 100       311 if(@create_dirs) {
151 13         52 $self->UmaskClear;
152 13         36 for my $create_dir (@create_dirs) {
153             # $create_dir =~ tr///; # this doesn't work to untaint with perl 5.6.1, use old method
154 15         76 $create_dir =~ /^(.*)$/s;
155 15         49 $create_dir = $1;
156 15 50       1377 if(mkdir($create_dir, $self->{dir_perms})) {
157 15 100       105 $asp->{dbg} && $asp->Debug("creating state dir $create_dir");
158             } else {
159 0         0 my $error = $!;
160 0 0       0 -d $create_dir || $self->{asp}->Error("can't create group dir $create_dir: $error");
161             }
162             }
163 13         54 $self->UmaskRestore;
164             }
165              
166             # INIT MLDBM::Sync DBM
167             {
168 125   50     172 local $MLDBM::UseDB = $state_db || 'SDBM_File';
  125         351  
169 125   100     308 local $MLDBM::Serializer = $state_serializer || 'Data::Dumper';
170             # clear current tied relationship first, if any
171 125         237 $self->{dbm} = undef;
172 125     0   1111 local $SIG{__WARN__} = sub {};
  0         0  
173            
174 125         628 my $error;
175 125         585 $self->{file} =~ /^(.*)$/; # untaint
176 125         385 $self->{file} = $1;
177 125         186 local $MLDBM::RemoveTaint = 1;
178 125         582 $self->{dbm} = &MLDBM::Sync::TIEHASH('MLDBM', $self->{file}, O_RDWR|O_CREAT, $self->{file_perms});
179 125 100       3147 $asp->{dbg} && $asp->Debug("creating dbm for file $self->{file}, db $MLDBM::UseDB, serializer: $MLDBM::Serializer");
180 125   100     1204 $error = $! || 'Undefined Error';
181              
182              
183 125 50       935 if(! $self->{dbm}) {
184 0         0 $self->{asp}->Error(qq{
185             Cannot tie to file $self->{file}, $error !!
186             Make sure you have the permissions on the directory set correctly, and that your
187             version of Data::Dumper is up to date. Also, make sure you have set StateDir to
188             to a good directory in the config file. StateDir defaults to Global/.state
189             });
190             }
191             }
192              
193 125         754 $self;
194             }
195              
196 0     0 0 0 sub Init { shift->{dbm}->CLEAR(); }
197 29     29 0 146 sub Size { shift->{dbm}->SyncSize; }
198 16     16 0 71 sub Delete { shift->{dbm}->CLEAR(); }
199 4     4 0 22 sub WriteLock { shift->{dbm}->Lock; }
200 0     0 0 0 sub ReadLock { shift->{dbm}->ReadLock; }
201 3     3 0 13 sub UnLock { shift->{dbm}->UnLock; }
202              
203             sub DeleteGroupId {
204 0     0 0 0 my $self = shift;
205              
206 0         0 my $group_dir = $self->{group_dir};
207 0 0       0 if(-d $group_dir) {
208 0         0 $self->{asp}{Internal}->LOCK;
209 0 0       0 if(rmdir($group_dir)) {
210 0         0 $self->{asp}->Debug("deleting group dir $group_dir");
211             } else {
212 0         0 $self->{asp}->Log("cannot delete group dir $group_dir: $!");
213             }
214 0         0 $self->{asp}{Internal}->UNLOCK;
215             }
216             }
217              
218 43     43 0 281 sub GroupId { shift->{group}; }
219              
220             sub GroupMembers {
221 74     74 0 117 my $self = shift;
222 74         201 local(*DIR);
223 74         90 my(%ids, @ids);
224              
225 74 50       2448 unless(opendir(DIR, $self->{group_dir})) {
226 0         0 $self->{asp}->Log("opening group $self->{group_dir} failed: $!");
227 0         0 return [];
228             }
229              
230 74         9715 for(readdir(DIR)) {
231 181 100       833 next if /^\.\.?$/;
232 33         320 $_ =~ /^(.*?)(\.[^\.]+)?$/;
233 33 50       93 next unless $1;
234 33         80 $ids{$1}++;
235             }
236              
237             # need to explicitly close directory, or we get a file
238             # handle leak on Solaris
239 74         847 closedir(DIR);
240              
241             # since not all sessions have their own dbms now, find session ids in $Internal too
242 74 50       272 if(my $internal = $self->{asp}{Internal}) {
243 74         305 my $cached_keys = {};
244 74 100       264 unless($cached_keys = $self->{asp}{internal_cached_keys}) {
245             map {
246 8 100       76 if(/^([0-9a-f]{2})/) {
  153         461  
247 57         321 $cached_keys->{$1}{$_}++
248             }
249             } keys %$internal;
250 8         65 $self->{asp}{internal_cached_keys} = $cached_keys;
251             }
252 74 100       280 if(my $group_keys = $cached_keys->{$self->{group}}) {
253 41         235 %ids = ( %ids, %$group_keys );
254             }
255             }
256              
257 74         207 @ids = keys %ids;
258              
259 74         6140 \@ids;
260             }
261              
262             sub DefaultGroups {
263 8     8 0 18 my $self = shift;
264 8         11 my(@ids);
265 8         26 local *STATEDIR;
266              
267 8 50       316 opendir(STATEDIR, $self->{state_dir})
268             || $self->{asp}->Error("can't open state dir $self->{state_dir}");
269 8         24 my $time = time;
270 8         331 for(readdir(STATEDIR)) {
271 98 100       216 next if /^\./;
272 82 100       177 next unless (length($_) eq $DefaultGroupIdLength);
273 74         149 push(@ids, $_);
274             }
275 8         132 closedir STATEDIR;
276              
277 8         51 \@ids;
278             }
279              
280             sub UmaskClear {
281 280     280 0 437 my $self = shift;
282 280 50       892 return if $self->{asp}{win32};
283 280         1452 $self->{umask_restore} = umask(0000);
284             }
285              
286             sub UmaskRestore {
287 280     280 0 608 my $self = shift;
288 280 50       886 return if $self->{asp}{win32};
289 280 50       764 if(defined $self->{umask_restore}) {
290 280         1285 umask($self->{umask_restore});
291             }
292             }
293              
294             sub DESTROY {
295 352     352   967 my $self = shift;
296 352 100       387 return unless %{$self};
  352         1453  
297 309 100       1680 return if $self->{destroyed}++;
298 199 100       488 $self->{dbm} && eval { $self->{dbm}->DESTROY };
  125         397  
299 199         1381 $self->{dbm} = undef;
300             }
301              
302             # don't need to skip DESTROY since we have it defined
303             # return if ($AUTOLOAD =~ /DESTROY/);
304             sub AUTOLOAD {
305 204     204   267 my $self = shift;
306 204         252 my $AUTOLOAD = $Apache::ASP::State::AUTOLOAD;
307 204         1032 $AUTOLOAD =~ s/^(.*)::(.*?)$/$2/o;
308              
309 204         240 my $value;
310 204         771 $value = $self->{dbm}->$AUTOLOAD(@_);
311              
312 204         13853 $value;
313             }
314              
315             sub TIEHASH {
316 56     56   105 my $type = shift;
317              
318             # dual tie contructor, if we receive a State object to tie
319             # then just return it, otherwise construct a new object
320             # before tieing
321 56 50       232 if((ref $_[0]) =~ /State/) {
322 0         0 $_[0];
323             } else {
324 56         166 bless &new(@_), $type;
325             }
326             }
327              
328             sub FETCH {
329 482     482   1124 my($self, $index) = @_;
330 482         538 my $value;
331              
332 482 50       2282 if($index eq '_FILE') {
    50          
333 0         0 $value = $self->{file};
334             } elsif($index eq '_SELF') {
335 0         0 $value = $self;
336             } else {
337 482         4156 $value = $self->{dbm}->FETCH($index);
338 482         103040 $self->{reads}++;
339             }
340              
341 482         3001 $value;
342             }
343              
344             sub STORE {
345 267     267   507 my $self = shift;
346              
347             # don't worry about overhead of Umask* routines, the STORE
348             # being called is much heavier
349 267         651 $self->UmaskClear;
350 267         1597 my $rv = $self->{dbm}->STORE(@_);
351 267         52686 $self->UmaskRestore;
352 267         524 $self->{writes}++;
353              
354 267         957 $rv;
355             }
356              
357 380     380 0 455 sub LOCK { my $self = tied(%{$_[0]}); $self->{dbm}->Lock(); }
  380         787  
  380         1309  
358 422     422 0 588 sub UNLOCK { my $self = tied(%{$_[0]}); $self->{dbm}->UnLock(); }
  422         837  
  422         1318  
359              
360             1;