File Coverage

blib/lib/Apache/ASP/State.pm
Criterion Covered Total %
statement 161 201 80.1
branch 54 90 60.0
condition 15 30 50.0
subroutine 23 30 76.7
pod 0 15 0.0
total 253 366 69.1


line stmt bran cond sub pod time code
1             package Apache::ASP::State;
2              
3 7     7   297 use MLDBM;
  7         97  
  7         120  
4 7     7   288 use MLDBM::Sync 0.25;
  7         2281  
  7         156  
5 7     7   235 use MLDBM::Sync::SDBM_File;
  7         84  
  7         178  
6 7     7   128 use SDBM_File;
  7         67  
  7         128  
7 7     7   116 use Data::Dumper;
  7         66  
  7         231  
8              
9 7     7   181 use strict;
  7         65  
  7         109  
10 7     7   132 no strict qw(refs);
  7         65  
  7         110  
11 7     7   111 use vars qw(%DB %CACHE $DefaultGroupIdLength);
  7         81  
  7         204  
12 7     7   111 use Fcntl qw(:flock O_RDWR O_CREAT);
  7         64  
  7         215  
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 28     28 0 301     my($asp, $id, $group) = @_;
39              
40 28 50       282     if($id) {
41 28         574 $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 28 100       313     if($group) {
49 15         137 $group =~ tr///;
50                 } else {
51 13         143 $group = substr($id, 0, $DefaultGroupIdLength)
52                 }
53              
54 28 50       294     unless($group) {
55 0         0 $asp->Error("no group defined for id $id");
56 0         0 return;
57                 }
58              
59 28         371     my $state_dir = $asp->{state_dir};
60 28         288     my $group_dir = $state_dir.'/'.$group;
61 28         387     my $lock_file = $group_dir.'/'.$id.'.lock';
62 28         297     my $file = $group_dir.'/'.$id;
63              
64             # we only need SDBM_File for internal, and its faster so use it
65 28         8066     my($state_db, $state_serializer);
66 28 100 100     672     if($id eq 'internal') {
    100          
67 7         105 $state_db = $Apache::ASP::DefaultStateDB;
68 7         72 $state_serializer = $Apache::ASP::DefaultStateSerializer;
69                 } elsif($asp->{Internal} && (length($id) > $DefaultGroupIdLength)) {
70             # don't get data for dummy group id sessions
71 14         137 my $internal = $asp->{Internal};
72 14         253 my $idata = $internal->{$id};
73 14 50 33     1087 if(! $idata->{state_db} || ! $idata->{state_serializer}) {
74 14   33     372 $state_db = $idata->{state_db} || $asp->{state_db} || $Apache::ASP::DefaultStateDB;
      33        
75 14   33     280 $state_serializer = $idata->{state_serializer} ||
      33        
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 14 50       205 if(length($id) > $DefaultGroupIdLength) {
81 14         1423 my $diff = 0;
82 14 50 33     317 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 14 50 33     321 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 14 50       182 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 7         86 ($state_db, $state_serializer) = ($asp->{state_db}, $asp->{state_serializer});
104                 }
105              
106 28         838     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 28 100       314     if ($group eq $id) {
122 6         70 return $self;
123                 }
124              
125 22 50       322     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 22         261 $self->{dir_perms} = 0750;
135 22         217 $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 22         231     my @create_dirs;
143 22 100       1604     unless(-d $state_dir) {
144 2         22 push(@create_dirs, $state_dir);
145                 }
146             # create group directory
147 22 100       632     unless(-d $group_dir) {
148 8         185 push(@create_dirs, $group_dir);
149                 }
150 22 100       247     if(@create_dirs) {
151 8         106 $self->UmaskClear;
152 8         83 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 10         141 $create_dir =~ /^(.*)$/s;
155 10         155 $create_dir = $1;
156 10 50       1501 if(mkdir($create_dir, $self->{dir_perms})) {
157 10 50       145 $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 8         108 $self->UmaskRestore;
164                 }
165              
166             # INIT MLDBM::Sync DBM
167                 {
168 22   50     199 local $MLDBM::UseDB = $state_db || 'SDBM_File';
  22         267  
169 22   100     364 local $MLDBM::Serializer = $state_serializer || 'Data::Dumper';
170             # clear current tied relationship first, if any
171 22         204 $self->{dbm} = undef;
172 22     0   487 local $SIG{__WARN__} = sub {};
  0         0  
173            
174 22         197 my $error;
175 22         330 $self->{file} =~ /^(.*)$/; # untaint
176 22         271 $self->{file} = $1;
177 22         226 local $MLDBM::RemoveTaint = 1;
178 22         386 $self->{dbm} = &MLDBM::Sync::TIEHASH('MLDBM', $self->{file}, O_RDWR|O_CREAT, $self->{file_perms});
179 22 50       250 $asp->{dbg} && $asp->Debug("creating dbm for file $self->{file}, db $MLDBM::UseDB, serializer: $MLDBM::Serializer");
180 22   100     709 $error = $! || 'Undefined Error';
181              
182              
183 22 50       341 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 22         312     $self;
194             }
195              
196 0     0 0 0 sub Init { shift->{dbm}->CLEAR(); }
197 8     8 0 118 sub Size { shift->{dbm}->SyncSize; }
198 1     1 0 14 sub Delete { shift->{dbm}->CLEAR(); }
199 0     0 0 0 sub WriteLock { shift->{dbm}->Lock; }
200 0     0 0 0 sub ReadLock { shift->{dbm}->ReadLock; }
201 0     0 0 0 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 0     0 0 0 sub GroupId { shift->{group}; }
219              
220             sub GroupMembers {
221 6     6 0 56     my $self = shift;
222 6         58     local(*DIR);
223 6         52     my(%ids, @ids);
224              
225 6 50       375     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 6         240     for(readdir(DIR)) {
231 30 100       374 next if /^\.\.?$/;
232 18         571 $_ =~ /^(.*?)(\.[^\.]+)?$/;
233 18 50       198 next unless $1;
234 18         201 $ids{$1}++;
235                 }
236              
237             # need to explicitly close directory, or we get a file
238             # handle leak on Solaris
239 6         120     closedir(DIR);
240              
241             # since not all sessions have their own dbms now, find session ids in $Internal too
242 6 50       75     if(my $internal = $self->{asp}{Internal}) {
243 6         58 my $cached_keys = {};
244 6 100       73 unless($cached_keys = $self->{asp}{internal_cached_keys}) {
245             map {
246 2 100       43 if(/^([0-9a-f]{2})/) {
  15         182  
247 7         105 $cached_keys->{$1}{$_}++
248             }
249             } keys %$internal;
250 2         28 $self->{asp}{internal_cached_keys} = $cached_keys;
251             }
252 6 50       78 if(my $group_keys = $cached_keys->{$self->{group}}) {
253 6         95 %ids = ( %ids, %$group_keys );
254             }
255                 }
256              
257 6         74     @ids = keys %ids;
258              
259 6         78     \@ids;
260             }
261              
262             sub DefaultGroups {
263 2     2 0 33     my $self = shift;
264 2         19     my(@ids);
265 2         21     local *STATEDIR;
266              
267 2 50       127     opendir(STATEDIR, $self->{state_dir})
268             || $self->{asp}->Error("can't open state dir $self->{state_dir}");
269 2         34     my $time = time;
270 2         87     for(readdir(STATEDIR)) {
271 12 100       207 next if /^\./;
272 8 100       87 next unless (length($_) eq $DefaultGroupIdLength);
273 6         61 push(@ids, $_);
274                 }
275 2         36     closedir STATEDIR;
276              
277 2         23     \@ids;
278             }
279              
280             sub UmaskClear {
281 78     78 0 815     my $self = shift;
282 78 50       1046     return if $self->{asp}{win32};
283 78         1160     $self->{umask_restore} = umask(0000);
284             }
285              
286             sub UmaskRestore {
287 78     78 0 717     my $self = shift;
288 78 50       1694     return if $self->{asp}{win32};
289 78 50       944     if(defined $self->{umask_restore}) {
290 78         1074 umask($self->{umask_restore});
291                 }
292             }
293              
294             sub DESTROY {
295 58     58   634     my $self = shift;
296 58 100       482     return unless %{$self};
  58         731  
297 50 100       882     return if $self->{destroyed}++;
298 28 100       317     $self->{dbm} && eval { $self->{dbm}->DESTROY };
  22         267  
299 28         300     $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 18     18   325