1 | # |
---|
2 | # Copyright (c) 2004-2007 - Consultas, PKG.fr |
---|
3 | # |
---|
4 | # This file is part of A2P. |
---|
5 | # |
---|
6 | # A2P is free software; you can redistribute it and/or modify |
---|
7 | # it under the terms of the GNU General Public License as published by |
---|
8 | # the Free Software Foundation; either version 2 of the License, or |
---|
9 | # (at your option) any later version. |
---|
10 | # |
---|
11 | # A2P is distributed in the hope that it will be useful, |
---|
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | # GNU General Public License for more details. |
---|
15 | # |
---|
16 | # You should have received a copy of the GNU General Public License |
---|
17 | # along with A2P; if not, write to the Free Software |
---|
18 | # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA |
---|
19 | # |
---|
20 | # $Id: JobStatus.pm 3 2007-10-18 16:20:19Z guillaume $ |
---|
21 | # |
---|
22 | |
---|
23 | use strict ; |
---|
24 | use Test ; |
---|
25 | use GDBM_File ; |
---|
26 | use Storable qw( freeze ); |
---|
27 | |
---|
28 | require 'test/A2P/Defaults.pm' ; |
---|
29 | |
---|
30 | BEGIN { |
---|
31 | plan |
---|
32 | tests => 89 , |
---|
33 | onfail => sub { exit(1) } |
---|
34 | } |
---|
35 | |
---|
36 | $| = 1 ; |
---|
37 | |
---|
38 | my %s = () ; |
---|
39 | my %h = () ; |
---|
40 | my %o = () ; |
---|
41 | |
---|
42 | our %STATS ; |
---|
43 | our ( $freezed, $SERVICE_TMP, $SHMDIR, $ADVANCED_DEBUGGING, $LOCKID, |
---|
44 | $LOGFILENAME, $DEBUG_IN_FILE ); |
---|
45 | our $Progname = 'TEST-JobStatus' ; |
---|
46 | |
---|
47 | &info("Loading A2P::JobStatus library"); |
---|
48 | ok require A2P::JobStatus ; |
---|
49 | |
---|
50 | sub dbm_base ; *dbm_base = \&A2P::JobStatus::dbm_base ; |
---|
51 | sub dbm_lock ; *dbm_lock = \&A2P::JobStatus::dbm_lock ; |
---|
52 | sub dbm_unlock ; *dbm_unlock = \&A2P::JobStatus::dbm_unlock ; |
---|
53 | sub is_status ; *is_status = \&A2P::JobStatus::is_status ; |
---|
54 | sub is_tied_status ; *is_tied_status = \&A2P::JobStatus::is_tied_status ; |
---|
55 | sub cansavetied ; *cansavetied = \&A2P::JobStatus::cansavetied ; |
---|
56 | sub tied_update_status ; *tied_update_status = \&A2P::JobStatus::tied_update_status ; |
---|
57 | sub tie_status_hash ; *tie_status_hash = \&A2P::JobStatus::tie_status_hash ; |
---|
58 | sub get_tied_ref ; *get_tied_ref = \&A2P::JobStatus::_get_tied_ref ; |
---|
59 | sub get_cache_ref ; *get_cache_ref = \&A2P::JobStatus::_get_cache_ref ; |
---|
60 | sub sync_dbm_to_db ; *sync_dbm_to_db = \&A2P::JobStatus::sync_dbm_to_db ; |
---|
61 | sub not_tied ; *not_tied = \&A2P::JobStatus::_not_tied ; |
---|
62 | sub not_tied ; *not_tied = \&A2P::JobStatus::_not_tied ; |
---|
63 | sub cache_cleaner ; *cache_cleaner = \&A2P::JobStatus::cache_cleaner ; |
---|
64 | sub sync_list ; *sync_list = \&A2P::JobStatus::sync_list ; |
---|
65 | sub sync_list_inject_again ; *sync_list_inject_again = \&A2P::JobStatus::sync_list_inject_again ; |
---|
66 | |
---|
67 | &info("Check some facility"); |
---|
68 | ok defined($SERVICE_TMP); |
---|
69 | ok defined($SHMDIR); |
---|
70 | ok defined(&dbm_base) ; |
---|
71 | ok &dbm_base =~ /jobstatus-/ ; |
---|
72 | ok &dbm_base , '/dev/shm/.test/.jobstatus-' ; |
---|
73 | ok defined(&cansavetied) ; |
---|
74 | |
---|
75 | &info("Check A2P::Status usability"); |
---|
76 | ok require A2P::Status ; |
---|
77 | $h{cached} = {} ; |
---|
78 | $s{status} = new A2P::Status($h{cached},{},'test') ; |
---|
79 | ok defined($s{status}) and ref($s{status}) =~ /^A2P::Status$/ ; |
---|
80 | ok &is_status($s{status}) ; |
---|
81 | ok ! &is_status(undef) ; |
---|
82 | ok ! &is_status('test') ; |
---|
83 | ok ! &is_status({}) ; |
---|
84 | ok ! &is_status('test',{}) ; |
---|
85 | ok ! &is_status('_test_',$h{cached}) ; |
---|
86 | ok $s{stored} = &freeze($s{status}) ; |
---|
87 | ok ! &is_tied_status('_SID_100_rev','UNIT-TEST') ; |
---|
88 | |
---|
89 | &info("Test locking"); |
---|
90 | $s{file} = &dbm_base . $LOCKID ; |
---|
91 | ok $s{file} , '/dev/shm/.test/.jobstatus-'.$LOCKID ; |
---|
92 | system "touch $s{file}" ; |
---|
93 | ok &dbm_lock($s{file}) ; |
---|
94 | ok -e $s{file}.'.LCK' ; |
---|
95 | my $lck = qx(/usr/sbin/lsof -l $s{file}.LCK 2>&1 | tee $s{file}.LCK 2>&1) ; |
---|
96 | &info("Check lsof result:", $lck, "toward: perl $$ $< [0-9]+wW REG [0-9,]+ 0"); |
---|
97 | ok $lck && $lck =~ /perl\s+$$\s+$<\s+\d+[wu]W\s+REG\s+[0-9,]+\s+0\s+/ ; |
---|
98 | ok &dbm_unlock ; |
---|
99 | &info("Locking file should not be removed as it could be shared"); |
---|
100 | ok -e $s{file}.'.LCK' ; |
---|
101 | ok ! qx(/usr/sbin/lsof $s{file}.LCK) ; |
---|
102 | |
---|
103 | &info("Check son can't access locked file"); |
---|
104 | ok &dbm_lock($s{file}) ; |
---|
105 | my $pid = fork ; |
---|
106 | unless ($pid) { |
---|
107 | $0 = 'son_trying_to_lock' ; |
---|
108 | &info("In $0..."); |
---|
109 | $SIG{ALRM} = sub { &info("$0: 5s timeout reached") ; exit(1) }; |
---|
110 | alarm 5 ; |
---|
111 | my $ret = &dbm_lock($s{file}); |
---|
112 | &info("$0: Locking returned $ret"); |
---|
113 | exit(10 + $ret); |
---|
114 | } |
---|
115 | ok waitpid($pid,0), $pid ; |
---|
116 | my $ret = $? ; |
---|
117 | ok defined($pid); |
---|
118 | &info("Check son returns without error"); |
---|
119 | ok $ret, 2560 ; |
---|
120 | ok $ret - 2816 ; |
---|
121 | |
---|
122 | &info("Check we can tie the status hash"); |
---|
123 | unlink $s{file} ; |
---|
124 | ok ! -e $s{file} ; |
---|
125 | $h{Tie} = &tie_status_hash($LOCKID); |
---|
126 | ok defined($h{Tie}); |
---|
127 | ok ref($h{Tie}), "GDBM_File" ; |
---|
128 | ok ¬_tied , 0 ; |
---|
129 | ok -e $s{file} ; |
---|
130 | &info("Check we have write access to tie"); |
---|
131 | ok &cansavetied , 1 ; |
---|
132 | delete $h{Tie} ; |
---|
133 | untie %{&get_tied_ref} ; |
---|
134 | ok &dbm_unlock ; |
---|
135 | |
---|
136 | &info("Check we can tie in read mode"); |
---|
137 | $h{Tie} = &tie_status_hash($LOCKID, 0); |
---|
138 | ok defined($h{Tie}); |
---|
139 | ok ref($h{Tie}), "GDBM_File" ; |
---|
140 | ok ¬_tied , 0 ; |
---|
141 | ok -e $s{file} ; |
---|
142 | &info("Check we don't have write access to tie"); |
---|
143 | ok &cansavetied , 0 ; |
---|
144 | delete $h{Tie} ; |
---|
145 | untie %{&get_tied_ref} ; |
---|
146 | ok &dbm_unlock ; |
---|
147 | |
---|
148 | sub get_file_tied { |
---|
149 | $h{FileTied} = &tie_status_hash($LOCKID); |
---|
150 | $h{TiedRef} = &get_tied_ref ; |
---|
151 | return 0 unless (defined($h{TiedRef})); |
---|
152 | return 1 unless (defined($h{FileTied})); |
---|
153 | return 2 unless (tied(%{$h{TiedRef}}) == $h{FileTied}); |
---|
154 | delete $h{TiedRef} ; |
---|
155 | return &cansavetied ? &get_tied_ref : 3 ; |
---|
156 | } |
---|
157 | |
---|
158 | sub release_file { |
---|
159 | delete $h{FileTied} ; |
---|
160 | untie %{&get_tied_ref}; |
---|
161 | &dbm_unlock ; |
---|
162 | } |
---|
163 | |
---|
164 | sub delete_file { |
---|
165 | my $lockid = @_ ? shift : $LOCKID ; |
---|
166 | unlink &dbm_base.$lockid ; |
---|
167 | unlink &dbm_base.$lockid.'.LCK' ; |
---|
168 | } |
---|
169 | |
---|
170 | sub dump_hash { |
---|
171 | $h{This} = &get_cache_ref ; |
---|
172 | map { print STDERR "CACHE: $_ -> ".$h{This}->{$_},($h{This}->{$_}=~/^HASH/? |
---|
173 | " -> (".keys(%{$h{This}->{$_}})." keys)":""),"\n" } |
---|
174 | sort(keys(%{$h{This}})) ; |
---|
175 | map { print STDERR "CACHE: __SID__ -> $_ -> ".$h{This}->{__SID__}->{$_},"\n" |
---|
176 | } sort(keys(%{$h{This}->{__SID__}})) ; |
---|
177 | $h{This} = &get_tied_ref ; |
---|
178 | map { print STDERR "TIED : $_ -> ", ( $h{This}->{$_} =~ $freezed ? |
---|
179 | "Freezed storable object" : $h{This}->{$_}),"\n" } |
---|
180 | sort(keys(%{$h{This}})) ; |
---|
181 | delete $h{This} ; |
---|
182 | } |
---|
183 | |
---|
184 | sub purge_hash { |
---|
185 | $h{This} = shift ; |
---|
186 | map { delete $h{$h{This}}->{$_} } keys(%{$h{$h{This}}}) ; |
---|
187 | delete $h{$h{This}} ; |
---|
188 | delete $h{This} ; |
---|
189 | } |
---|
190 | |
---|
191 | # clean |
---|
192 | &delete_file ; |
---|
193 | unlink $s{file} ; |
---|
194 | unlink $s{file} . '.LCK' ; |
---|
195 | |
---|
196 | &info("Check tied_update_status API without DB connection"); |
---|
197 | ok &tied_update_status('UNIT-TEST',5,'#'); |
---|
198 | &get_file_tied ; |
---|
199 | ok $h{Ref} = &get_tied_ref ; |
---|
200 | ok $h{Ref} =~ /^HASH/ ; |
---|
201 | ok $h{cache} = &get_cache_ref ; |
---|
202 | ok $h{cache} =~ /^HASH/ ; |
---|
203 | #&dump_hash ; |
---|
204 | ok $h{cache}->{'UNIT-TEST'} ; |
---|
205 | $o{test} = $h{cache}->{'UNIT-TEST'} ; |
---|
206 | $s{sid} = $o{test}->get_sid_index ; |
---|
207 | &info("SID should be AFPNAME by default"); |
---|
208 | ok $s{sid}, 0 ; |
---|
209 | ok $h{cache}->{'__SID__'} ; |
---|
210 | &info("Should not be in SID cache"); |
---|
211 | ok $h{cache}->{'__SID__'}->{$s{sid}}, undef ; |
---|
212 | ok $h{Ref}->{$o{test}->get_sid_key} ; |
---|
213 | ok $h{Ref}->{$o{test}->get_sid_version_key} ; |
---|
214 | # Status: tied = 2, cached = 3 |
---|
215 | ok keys(%{$h{Ref}}), 2 ; |
---|
216 | ok keys(%{$h{cache}}), 3 ; |
---|
217 | &info("SID $s{sid} at revision 1"); |
---|
218 | ok $o{test}->is_older_than_tied, 0 ; |
---|
219 | $o{test}->{REV} = 0 ; # Artificialy make object older |
---|
220 | ok $o{test}->is_older_than_tied, 1 ; |
---|
221 | #&dump_hash ; |
---|
222 | delete $h{cache} ; |
---|
223 | &release_file ; |
---|
224 | |
---|
225 | &info("Try status update"); |
---|
226 | &info("First call set the real JOBID name"); |
---|
227 | &tied_update_status('UNIT-TEST',5,'#',{ JOBID => 'JOBID-NAME' }); |
---|
228 | &info("SID $s{sid} at revision 2"); |
---|
229 | &tied_update_status('UNIT-TEST',5,'#',{JID => 'JOBID-NAME',STATUS=>'OK'}); |
---|
230 | &info("SID $s{sid} at revision 3"); |
---|
231 | &get_file_tied ; |
---|
232 | ok $h{Ref} = &get_tied_ref ; |
---|
233 | ok $h{Ref}->{'JOBID-NAME'}, 'UNIT-TEST' ; |
---|
234 | #&dump_hash ; |
---|
235 | delete $h{Ref} ; |
---|
236 | &release_file ; |
---|
237 | |
---|
238 | &info("Check we retrieve the previous status from cache"); |
---|
239 | ok $h{cache} = &get_cache_ref ; |
---|
240 | ok defined($h{cache}->{'UNIT-TEST'}) ; |
---|
241 | ok $h{cache}->{'UNIT-TEST'}, $h{cache}->{'JOBID-NAME'} ; |
---|
242 | $o{test} = $h{cache}->{'UNIT-TEST'} ; |
---|
243 | ok $o{test}->get_sid_index , 0 ; |
---|
244 | ok $o{test}->{JOBID}, 'JOBID-NAME' ; |
---|
245 | ok $o{test}->{AFP}, 'UNIT-TEST' ; |
---|
246 | ok $o{test}->is_job , 'JOBID-NAME' ; |
---|
247 | ok ! defined($h{cache}->{'__SID__'}->{$s{sid}}) ; |
---|
248 | &purge_hash('cache'); |
---|
249 | |
---|
250 | &release_file ; |
---|
251 | &delete_file ; |
---|
252 | |
---|
253 | sub populate_tie { |
---|
254 | my $count = shift ; |
---|
255 | &release_file ; |
---|
256 | ok ¬_tied, 1 ; |
---|
257 | ok $h{cached} = &get_cache_ref ; |
---|
258 | ok $h{'tied'} = &get_tied_ref ; |
---|
259 | &get_file_tied ; |
---|
260 | ok ¬_tied, 0 ; |
---|
261 | my $index = 1 ; |
---|
262 | while ($index <= $count) { |
---|
263 | my $test = sprintf('test-%s-%06d',$LOCKID,$index); |
---|
264 | $s{status} = new A2P::Status($h{cached},$h{'tied'},$test) ; |
---|
265 | $s{status}->save_tied ; |
---|
266 | $index ++ ; |
---|
267 | } ; |
---|
268 | delete $s{status} ; |
---|
269 | } |
---|
270 | |
---|
271 | &info("Check sync_cache_with_gdbm"); |
---|
272 | $LOCKID = 'TEST-1' ; |
---|
273 | ok $h{cached} = &get_cache_ref ; |
---|
274 | ok $h{'tied'} = &get_tied_ref ; |
---|
275 | # Status: tied = 0, cached = 0 |
---|
276 | ok keys(%{$h{'tied'}}), 0 ; |
---|
277 | ok keys(%{$h{cached}}), 0 ; |
---|
278 | #&dump_hash ; |
---|
279 | |
---|
280 | &info("Create 6 status for $LOCKID"); |
---|
281 | &populate_tie(6); |
---|
282 | # Status: tied = 6*2, cached = 6+2 |
---|
283 | ok keys(%{$h{'tied'}}), 12 ; |
---|
284 | ok keys(%{$h{cached}}), 8 ; # with __SID__ index and __GDBM_WRITER__ |
---|
285 | ok defined($h{cached}->{'__SID__'}) ; |
---|
286 | ok defined($h{cached}->{'__GDBM_WRITER__'}) ; |
---|
287 | ok keys(%{$h{cached}->{'__SID__'}}), 0 ; |
---|
288 | #&dump_hash ; |
---|
289 | |
---|
290 | $LOCKID = 'TEST-2' ; |
---|
291 | &info("Create 10 other status for $LOCKID"); |
---|
292 | &populate_tie(10); |
---|
293 | # Status: tied = 10*2, cached = 6+10+2 |
---|
294 | ok keys(%{$h{'tied'}}), 20 ; |
---|
295 | ok keys(%{$h{cached}}), 18 ; # with __SID__ index and __GDBM_WRITER__ |
---|
296 | #&dump_hash ; |
---|
297 | |
---|
298 | &info("Remove status from cache"); |
---|
299 | map { |
---|
300 | $h{cached}->{$_}->remove_from_cache ; |
---|
301 | } grep { $_ !~ /^__/ } keys(%{$h{cached}}) ; |
---|
302 | # Status: tied = 10*2, cached = 2 |
---|
303 | ok keys(%{$h{'tied'}}), 20 ; |
---|
304 | ok keys(%{$h{cached}}), 2 ; # with __SID__ index and __GDBM_WRITER__ |
---|
305 | ok keys(%{$h{cached}->{'__SID__'}}), 0 ; |
---|
306 | &release_file ; |
---|
307 | ok ¬_tied, 1 ; |
---|
308 | # Status: tied = 0, cached = 1 |
---|
309 | ok keys(%{$h{'tied'}}), 0 ; |
---|
310 | ok keys(%{$h{cached}}), 1 ; # with only __SID__ index |
---|
311 | ok keys(%{$h{cached}->{'__SID__'}}), 0 ; |
---|
312 | &dump_hash ; |
---|
313 | |
---|
314 | &release_file ; |
---|
315 | |
---|
316 | &info("Internal statistics:") if (keys(%STATS)); |
---|
317 | map { &info(" $_: $STATS{$_}") } grep { exists($STATS{$_}) } qw( |
---|
318 | CACHED-STATUS-OBJECT-KEPT CACHED-STATUS-OBJECT-CLEANED |
---|
319 | STATUS-OBJECT-KEPT-IN-CACHE STATUS-OBJECT-KEPT-IN-CACHE-MAX |
---|
320 | CACHED-STATUS-OBJECT-CHECKED CACHED-STATUS-OBJECT-CHECKED-MAX |
---|
321 | STATUS-OBJECT-EARLY-CLEANED CACHE-KEYS-COUNT CACHE-KEYS-COUNT |
---|
322 | TIMING-SYNC-CACHE-API NO-SYNC-NEEDED-TEST-1 LOCKIDS-CHECK-CALL |
---|
323 | LOCKIDS-CHECK-LISTS-NOT-EMPTY TEST-1-TIE-UPDATED |
---|
324 | SYNC-LIST-REPOPULATE-TEST-1 |
---|
325 | ); |
---|
326 | |
---|
327 | 1 ; |
---|