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 root $ |
---|
21 | # |
---|
22 | # Some job status subfunctions callable from a2p, a2p-status and webmin modules |
---|
23 | # |
---|
24 | |
---|
25 | package A2P::JobStatus ; |
---|
26 | |
---|
27 | use strict; |
---|
28 | use Fcntl; |
---|
29 | use Time::HiRes qw( usleep gettimeofday tv_interval) ; |
---|
30 | use Fcntl qw(:flock F_SETLK F_WRLCK SEEK_SET); |
---|
31 | use File::stat; |
---|
32 | use IO::Socket; |
---|
33 | use GDBM_File; |
---|
34 | use A2P::Globals ; |
---|
35 | use A2P::Syslog ; |
---|
36 | use A2P::Status ; |
---|
37 | use A2P::Tools qw( SharedList FreeSharedList ms ); |
---|
38 | |
---|
39 | BEGIN { |
---|
40 | use Exporter (); |
---|
41 | our ( $VERSION , @ISA , @EXPORT_OK ); |
---|
42 | |
---|
43 | $VERSION = sprintf "%s", q$Rev: 986 $ =~ /(\d[0-9.]+)\s+/ ; |
---|
44 | |
---|
45 | @ISA = qw(Exporter); |
---|
46 | @EXPORT_OK = qw( |
---|
47 | &sync_dbm_to_db &a2pjobstate &otherjobstate &getstatus_from_db |
---|
48 | &get_status |
---|
49 | ); |
---|
50 | } |
---|
51 | our $VERSION ; |
---|
52 | |
---|
53 | my %TIED_STATUS = () ; # Tied hash |
---|
54 | my %STATUS = () ; # Status object cache |
---|
55 | |
---|
56 | my $LCK ; |
---|
57 | my $CURRENTMODE = 0 ; # Access mode to tie: 0 = RO, 1 = R/W |
---|
58 | |
---|
59 | sub _freezed_status_re { |
---|
60 | qr/^\x04.*A2P::Status/ |
---|
61 | } |
---|
62 | |
---|
63 | sub _get_tied_ref { |
---|
64 | return \%TIED_STATUS ; |
---|
65 | } |
---|
66 | |
---|
67 | sub _not_tied { |
---|
68 | return tied(%TIED_STATUS) ? 0 : 1 ; |
---|
69 | } |
---|
70 | |
---|
71 | sub _get_cache_ref { |
---|
72 | return \%STATUS ; |
---|
73 | } |
---|
74 | |
---|
75 | sub cansavetied { |
---|
76 | $CURRENTMODE = 0 if _not_tied ; |
---|
77 | return $CURRENTMODE ; |
---|
78 | } |
---|
79 | |
---|
80 | sub a2pjobstate { |
---|
81 | return 1 unless ( $SCAN_SPOOL and $KEEP_JOBSTATUS ); |
---|
82 | &TIMESTAT('UPDATE-JOBSTATE'); |
---|
83 | |
---|
84 | my $ret = &tied_update_status(@_); |
---|
85 | |
---|
86 | # 9. Call the cache cleaner after the status is updated |
---|
87 | &cache_cleaner() ; |
---|
88 | |
---|
89 | &TIMESTAT('UPDATE-JOBSTATE'); |
---|
90 | return $ret ; |
---|
91 | } |
---|
92 | |
---|
93 | sub otherjobstate { |
---|
94 | # Check gdbm file exists before update specially if we are root !!! to |
---|
95 | # avoid create an unreadable gdbm file for services |
---|
96 | return 0 unless -e &dbm_base . $LOCKID ; |
---|
97 | return &tied_update_status(@_); |
---|
98 | } |
---|
99 | |
---|
100 | sub newstatus_dbm_base { |
---|
101 | return $SHMDIR . '/.new-status-' ; |
---|
102 | } |
---|
103 | |
---|
104 | sub dbm_base { |
---|
105 | return $SHMDIR . '/.jobstatus-' ; |
---|
106 | } |
---|
107 | |
---|
108 | sub dbm_lock { |
---|
109 | my $file = shift ; |
---|
110 | my $lockid = shift || $LOCKID ; |
---|
111 | |
---|
112 | return &Error("Can't open lock file to update $file job status: $!") |
---|
113 | unless (open($LCK, '>', $file.'.LCK')); |
---|
114 | |
---|
115 | my $tries = 0 ; |
---|
116 | while ( $tries < 5 ) { |
---|
117 | # Lock status update as only one thread should update status at a time |
---|
118 | if (flock($LCK, LOCK_EX | LOCK_NB)) { |
---|
119 | &MAXSTAT('STATUS-LOCK-RETRY',$tries); |
---|
120 | return 1 ; |
---|
121 | } |
---|
122 | usleep $USLEEP >> 2 ; |
---|
123 | $tries ++ ; |
---|
124 | } |
---|
125 | close($LCK); |
---|
126 | undef $LCK ; |
---|
127 | &MAXSTAT('STATUS-LOCK-RETRY',$tries); |
---|
128 | return 0 ; |
---|
129 | } |
---|
130 | |
---|
131 | sub dbm_unlock { |
---|
132 | my $lockid = shift || $LOCKID ; |
---|
133 | return 1 unless (defined($LCK)); |
---|
134 | |
---|
135 | flock($LCK, LOCK_UN); |
---|
136 | $CURRENTMODE = 0 ; |
---|
137 | close($LCK); |
---|
138 | undef $LCK ; |
---|
139 | |
---|
140 | # Key used by A2P::Status API to know if it can write to tiehash |
---|
141 | delete $STATUS{__GDBM_WRITER__}; |
---|
142 | |
---|
143 | 1 ; |
---|
144 | } |
---|
145 | |
---|
146 | my $search_status = '' ; |
---|
147 | sub get_status { |
---|
148 | my $name = shift ; |
---|
149 | my ( $key, $status, $found ) = ( '', 0, '' ); |
---|
150 | |
---|
151 | # Parse each status in cache |
---|
152 | foreach (( $key, $status ) = each(%STATUS)) { |
---|
153 | next unless (&is_status($status)); |
---|
154 | if ($status->is_job eq $name or $status->{JOBID} eq $name |
---|
155 | or $status->{AFP} eq $name) { |
---|
156 | $found = $key ; |
---|
157 | last ; |
---|
158 | } |
---|
159 | } |
---|
160 | |
---|
161 | # Set we are searching for this job for next list scan if not found |
---|
162 | if ($found) { |
---|
163 | $search_status = '' unless ( $search_status ne $name ); |
---|
164 | |
---|
165 | } else { |
---|
166 | &StatusDebug("Searching for status object of $name"); |
---|
167 | $search_status = $name ; |
---|
168 | $status = 0 ; |
---|
169 | } |
---|
170 | |
---|
171 | return $status ; |
---|
172 | } |
---|
173 | |
---|
174 | my @sync_list = ( {}, {}, {}, {} ) ; # Array of 4 hash refs |
---|
175 | # 0 -> Lists to sync cache by lockid (keys like __.*__ are based on cache keys) |
---|
176 | # 1 -> Lists of expected keys to be synchronised |
---|
177 | # 2 -> Lists of timer for resynchronization |
---|
178 | # 3 -> Lists of keys to recheck as writer |
---|
179 | sub sync_list { |
---|
180 | # Return a given number of element to check in sync_cache API |
---|
181 | my $lockid = shift || $LOCKID ; |
---|
182 | |
---|
183 | my ( $lists, $shorts, $timings ) = @sync_list ; |
---|
184 | |
---|
185 | $lists->{$lockid} = [] unless (exists($lists->{$lockid})); |
---|
186 | my $list = $lists->{$lockid} ; |
---|
187 | |
---|
188 | $shorts->{$lockid} = {} unless (exists($shorts->{$lockid})); |
---|
189 | my $shortlist = $shorts->{$lockid} ; |
---|
190 | |
---|
191 | # Check if we need to repopulate the list |
---|
192 | unless ( @{$list} ) { |
---|
193 | # Get timing |
---|
194 | $timings->{$lockid} = [ 0, 0 ] unless (exists($timings->{$lockid})); |
---|
195 | my $timing = $timings->{$lockid} ; |
---|
196 | |
---|
197 | if ($timing->[0]) { |
---|
198 | # Check how many time with passed to come back here: stop chrono |
---|
199 | &TIMESTAT('SYNC-LIST-PROCESSED-'.$lockid); |
---|
200 | |
---|
201 | # Update some statistics |
---|
202 | my $delay = time - $timing->[0] ; |
---|
203 | &MAXSTAT('SYNC-LIST-RATE-'.$lockid, |
---|
204 | sprintf('%.2f',$timing->[1]/$delay)) if $delay; |
---|
205 | |
---|
206 | $timing->[0] += $delay ; # Update to current time |
---|
207 | $timing->[1] = 0 ; # Init list count |
---|
208 | |
---|
209 | } else { |
---|
210 | # Initialize processing timer |
---|
211 | $timing->[0] = time ; # Set to current timer |
---|
212 | $timing->[1] = 0 ; # Init list count |
---|
213 | } |
---|
214 | |
---|
215 | &TIMESTAT('SYNC-LIST-REPOPULATE-'.$lockid); |
---|
216 | &UPSTAT('SYNC-LIST-REPOPULATE-'.$lockid); |
---|
217 | |
---|
218 | # Repopulate list |
---|
219 | push @{$list}, grep { &is_tied_status($_) } keys(%TIED_STATUS) ; |
---|
220 | |
---|
221 | $timing->[1] += @{$list} ; |
---|
222 | |
---|
223 | &MAXSTAT('SYNC-LIST-COUNT-'.$lockid,$timing->[1]); |
---|
224 | &MAXSTAT('SYNC-LIST-REPOPULATED-'.$lockid,scalar(@{$list})); |
---|
225 | &TIMESTAT('SYNC-LIST-REPOPULATE-'.$lockid); |
---|
226 | &TIMESTAT('SYNC-LIST-PROCESSED-'.$lockid); # Start the come back chono |
---|
227 | } |
---|
228 | |
---|
229 | # Get list count to return |
---|
230 | my $return_count = $MAX_CONV_RATE > 0 ? $MAX_CONV_RATE : 20 ; |
---|
231 | |
---|
232 | # Synchronize quickly the short/expected list |
---|
233 | my @list = () ; |
---|
234 | my @shortlist = keys(%{$shortlist}) ; |
---|
235 | my $sync_shortlist = @shortlist < $return_count ? |
---|
236 | scalar(@shortlist) : $return_count ; |
---|
237 | if ($sync_shortlist) { |
---|
238 | # Update @list with shortlist and remove shortlist entries |
---|
239 | map { push @list, $_ ; delete $shortlist->{$_} } |
---|
240 | splice @shortlist, 0, $sync_shortlist ; |
---|
241 | } |
---|
242 | &MAXSTAT('SYNC-LIST-SHORT-'.$lockid, $sync_shortlist); |
---|
243 | |
---|
244 | # Synchronize slowly the complete list |
---|
245 | my $sync_longlist = @list < $return_count ? $return_count - @list : 1 ; |
---|
246 | |
---|
247 | # Update list with slow list elements |
---|
248 | push @list, splice @{$list}, 0, |
---|
249 | $sync_longlist > @{$list} ? scalar(@{$list}) : $sync_longlist |
---|
250 | if @{$list} ; |
---|
251 | |
---|
252 | &MAXSTAT('SYNC-LIST-LONG-'.$lockid, $sync_longlist); |
---|
253 | |
---|
254 | &MAXSTAT('SYNC-LIST-'.$lockid,scalar(@list)); |
---|
255 | |
---|
256 | return @list ; |
---|
257 | } |
---|
258 | |
---|
259 | sub sync_list_inject_again { |
---|
260 | # Empty the current synching list by re-injecting them in expected keys list |
---|
261 | my $lockid = shift || $LOCKID ; |
---|
262 | my $array = shift || () ; |
---|
263 | return unless @{$array} ; |
---|
264 | &UPSTAT('SYNC-INJECT-AGAIN-'.$lockid); |
---|
265 | &MAXSTAT('SYNC-INJECTED-AGAIN-'.$lockid,scalar(@{$array})); |
---|
266 | map { |
---|
267 | &Debug("Inject $_ in $lockid shortlist") if ($ADVANCED_DEBUGGING); |
---|
268 | $sync_list[1]->{$lockid}->{$_} = 1 |
---|
269 | } splice @{$array} ; |
---|
270 | } |
---|
271 | |
---|
272 | sub in_expected_sync_list { |
---|
273 | # Populate expected keys to be synched |
---|
274 | my $lockid = shift ; |
---|
275 | my $key = shift ; |
---|
276 | |
---|
277 | my $this = exists($sync_list[1]->{$lockid}) ? |
---|
278 | $sync_list[1]->{$lockid} : $sync_list[1]->{$lockid} = {} ; |
---|
279 | $this->{$key} = 1 ; |
---|
280 | |
---|
281 | &Debug("Expecting synchronization on $key in $lockid shortlist") |
---|
282 | if ($ADVANCED_DEBUGGING); |
---|
283 | &UPSTAT('EXPECTED-SYNC-ADDED-'.$lockid); |
---|
284 | } |
---|
285 | |
---|
286 | sub sync_new_list { |
---|
287 | # Check new status to be synched |
---|
288 | my $lockid = shift || $LOCKID ; |
---|
289 | my @new_status = () ; |
---|
290 | my $shared_list = &SharedList( $lockid ); |
---|
291 | if (@{$shared_list}) { |
---|
292 | map { |
---|
293 | my $status = shift @{$shared_list} ; |
---|
294 | push @new_status, $status ; |
---|
295 | &Debug("Got '$status' from '$lockid' SharedList at #$_") |
---|
296 | if ($ADVANCED_DEBUGGING); |
---|
297 | } 0..$#{$shared_list} ; |
---|
298 | } |
---|
299 | &FreeSharedList( $lockid ); |
---|
300 | return () unless @new_status ; # Avoid statistics if nothing new found |
---|
301 | &UPSTAT('SYNC-NEW-LIST-'.$lockid); |
---|
302 | &MAXSTAT('SYNC-NEW-LIST-COUNT-'.$lockid,scalar(@new_status)); |
---|
303 | return @new_status ; |
---|
304 | } |
---|
305 | |
---|
306 | sub tie_status_hash { |
---|
307 | my $lockid = shift || $LOCKID ; |
---|
308 | $CURRENTMODE = shift ; |
---|
309 | $CURRENTMODE = 1 unless (defined($CURRENTMODE)); |
---|
310 | |
---|
311 | my $file = &dbm_base . $lockid ; |
---|
312 | |
---|
313 | # Synchronize mode with lock status, we can only write if we have an |
---|
314 | # exclusive lock on the file |
---|
315 | $CURRENTMODE = $CURRENTMODE ? &dbm_lock( $file, $lockid ) : 0 ; |
---|
316 | |
---|
317 | if (tied(%TIED_STATUS)) { |
---|
318 | &UPSTAT('WARNING-UNEXPECTED-'.$lockid.'-UNTIE-NEEDED'); |
---|
319 | &StatusDebug("Can't tie again hash, trying to untie first"); |
---|
320 | untie %TIED_STATUS ; |
---|
321 | } |
---|
322 | |
---|
323 | # Tie STATUS hash with read/write access |
---|
324 | my $ret = tie( %TIED_STATUS , 'GDBM_File' , $file , |
---|
325 | ($CURRENTMODE ? GDBM_WRCREAT|GDBM_NOLOCK : GDBM_READER) , oct(660) ); |
---|
326 | |
---|
327 | # Inform A2P::Status API it can write in tiehash |
---|
328 | if (defined($ret) and $ret == tied(%TIED_STATUS)) { |
---|
329 | $STATUS{__GDBM_WRITER__} = $CURRENTMODE ; |
---|
330 | } else { |
---|
331 | delete $STATUS{__GDBM_WRITER__} ; |
---|
332 | } |
---|
333 | |
---|
334 | return $ret ; |
---|
335 | } |
---|
336 | |
---|
337 | my $shrink_timer = {} ; # Timers to reorganize gdbms |
---|
338 | sub _shrink_gdbm_file { |
---|
339 | my $lockid = shift ; |
---|
340 | |
---|
341 | # Can only shrink GDBM files at least each minute |
---|
342 | return 0 if ( exists($shrink_timer->{$lockid}) |
---|
343 | and &tv_interval($shrink_timer->{$lockid}) < 60 ); |
---|
344 | |
---|
345 | # Get file statistics |
---|
346 | my $stat = stat( &dbm_base . $lockid ) or return 0 ; |
---|
347 | |
---|
348 | # Check if we can shrink GDBM file each minute if file is greater than 1Mb |
---|
349 | my $delay = $stat->size > 1024000 ? 60 : 600 ; # default is 10 minutes |
---|
350 | return if ( exists($shrink_timer->{$lockid}) |
---|
351 | and &tv_interval($shrink_timer->{$lockid}) < $delay ); |
---|
352 | |
---|
353 | my $stat_tag = 'REORGANIZE-GDBM-'.$lockid ; |
---|
354 | &UPSTAT($stat_tag.'-CHECK'); |
---|
355 | |
---|
356 | # Get file time update and apply factor relative to file size |
---|
357 | my $condition = ( time - $stat->mtime ) * int( $stat->size / 512000 ) ; |
---|
358 | |
---|
359 | # Condition is equivalent to a GDBM file not used since at least 40 seconds |
---|
360 | # if the file size is about 0,5-1 Mb. Lower size won't be shrinked. Greater |
---|
361 | # will be shrink in a less time interval. On a high load, the shrink will |
---|
362 | # be delayed until activity is reduced on a minimum basis: at least 1 second |
---|
363 | # of inactivity and file size is greater than 20 Mbytes |
---|
364 | if ( $condition > 40 ) { |
---|
365 | $! = 0 ; |
---|
366 | &UPSTAT($stat_tag.'-TRY'); |
---|
367 | &MAXSTAT($stat_tag.'-FILE-SIZE',$stat->size); |
---|
368 | my $shrinked = 0 ; |
---|
369 | my $gdbm = tied(%TIED_STATUS) ; |
---|
370 | if (ref($gdbm) =~ /^GDBM_File/i ) { |
---|
371 | &TIMESTAT($stat_tag); |
---|
372 | $shrinked = $gdbm->reorganize() ; |
---|
373 | &TIMESTAT($stat_tag); |
---|
374 | } |
---|
375 | &Info("Bad shrink on $lockid GDBM jobsstatus file: $!") |
---|
376 | unless (defined($shrinked) and $shrinked > -1 and ! $!); |
---|
377 | $shrink_timer->{$lockid} = [ &gettimeofday() ] ; |
---|
378 | |
---|
379 | } else { |
---|
380 | &UPSTAT($stat_tag.'-SKIPPED'); |
---|
381 | } |
---|
382 | } |
---|
383 | |
---|
384 | my %StatusDebug = ( |
---|
385 | 1 => "Cleaning jobstatus objects tied in hash", |
---|
386 | 2 => "Get status object", |
---|
387 | 3 => "Cleaning jobstatus objects cache", |
---|
388 | 4 => "Updating object status", |
---|
389 | 5 => "Updating object infos", |
---|
390 | 6 => "Saving objects status to tied hash", |
---|
391 | 7 => "Status update done" |
---|
392 | ); |
---|
393 | |
---|
394 | my %MESG = () ; |
---|
395 | sub StatusDebug { |
---|
396 | # Specific debugging handling to keep good performance when not activated |
---|
397 | return unless ($ADVANCED_DEBUGGING); |
---|
398 | my $add = "" ; |
---|
399 | if (defined($MESG{$_[0]}) and my ( $repeat, $timer ) = @{$MESG{$_[0]}}) { |
---|
400 | $MESG{$_[0]}->[0] ++ ; |
---|
401 | return unless (&tv_interval($timer)>=60); |
---|
402 | $add = " ($repeat times)" unless ($repeat==1); |
---|
403 | |
---|
404 | } else { |
---|
405 | $MESG{$_[0]} = [ 1 ] ; |
---|
406 | } |
---|
407 | $MESG{$_[0]}->[1] = [ &gettimeofday() ] ; |
---|
408 | &Debug($_[0] =~ /^\d+$/ ? $StatusDebug{$_[0]}.$add : "@_$add"); |
---|
409 | } |
---|
410 | |
---|
411 | my $RESYNCH_TIMEOUT = 10 ; # 10 seconds before synchronizing in tied hash |
---|
412 | sub sync_lockid { |
---|
413 | # Sync the object for a lockid from tied to DB |
---|
414 | # Return true if we need to recheck as writer |
---|
415 | my $lockid = shift ; |
---|
416 | my $mode = shift ; |
---|
417 | |
---|
418 | # Check initialization |
---|
419 | $sync_list[3]->{$lockid} = {} unless (exists($sync_list[3]->{$lockid})); |
---|
420 | my $resynch_list = $sync_list[3]->{$lockid} ; |
---|
421 | |
---|
422 | my $status_count = 0 ; |
---|
423 | my $resynch_needed = 0 ; |
---|
424 | my $timeout = &ms( -$RESYNCH_TIMEOUT ); |
---|
425 | |
---|
426 | my @keys ; # List of keys to handle |
---|
427 | |
---|
428 | # Get a list of keys to check regarding the called mode |
---|
429 | if ($mode) { |
---|
430 | # As writer we should also synchronize with DB in the same time |
---|
431 | my @resynch_keys = keys(%{$resynch_list}) ; |
---|
432 | &MAXMINSTAT('SYNC-LOCKID-RESYNCH-KEYS-'.$lockid,scalar(@resynch_keys)); |
---|
433 | @keys = grep { $resynch_list->{$_} < $timeout } @resynch_keys ; |
---|
434 | |
---|
435 | } else { |
---|
436 | # Search for status to synchronize with DB |
---|
437 | # Get also new status from shared list |
---|
438 | @keys = ( &sync_new_list($lockid), &sync_list( $lockid ) ) ; |
---|
439 | } |
---|
440 | |
---|
441 | my @too_quick = () ; |
---|
442 | |
---|
443 | # Set a counter to limit processing to not overload the service |
---|
444 | # But we should process at least 10% of the list in case of big load |
---|
445 | my $long_processing = 0 ; |
---|
446 | my $max_long_processing = @keys > 256 ? @keys >> 4 : 16 ; |
---|
447 | |
---|
448 | while ( @keys ) { |
---|
449 | my $key = shift @keys ; |
---|
450 | |
---|
451 | $status_count ++ ; |
---|
452 | |
---|
453 | # Get the status object or continue |
---|
454 | my $status = new A2P::Status( \%STATUS, \%TIED_STATUS, $key ) |
---|
455 | or next ; |
---|
456 | |
---|
457 | # Skip if not a status |
---|
458 | next unless (&is_status($status)); |
---|
459 | |
---|
460 | # Keep this status in cache for a while if we are searching for |
---|
461 | if ( $search_status and ( $status->is_job eq $search_status |
---|
462 | or $status->{JOBID} eq $search_status |
---|
463 | or $status->{AFP} eq $search_status )) { |
---|
464 | $status->cached ; |
---|
465 | $search_status = '' ; |
---|
466 | } |
---|
467 | |
---|
468 | # Don't recheck status too quickly |
---|
469 | &UPSTAT('SYNC-LOCKID-QUICK-CHECK-DB-SYNCH-'.$lockid); |
---|
470 | if ( ! $mode and $status->checking_too_quickly() ) { |
---|
471 | push @too_quick, $key if ($status->dirty_bit(3)); |
---|
472 | &UPSTAT('SYNC-LOCKID-TOO-QUICK-DB-SYNCH-'.$lockid); |
---|
473 | next ; |
---|
474 | } |
---|
475 | |
---|
476 | # Remark: The dirty bit 3 should only be reset when every steps are |
---|
477 | # finished to guaranty the status is in DB |
---|
478 | |
---|
479 | # Synchronize status with DB |
---|
480 | if ($status->sync_with_db) { |
---|
481 | &UPSTAT('SYNC-LOCKID-DB-SYNCHED-'.$lockid); |
---|
482 | if ($status->is_finished) { |
---|
483 | &UPSTAT('SYNC-LOCKID-FINISHED-'.$lockid.'-'.$mode); |
---|
484 | if ($mode) { |
---|
485 | &Debug("Synchro $lockid to DB for $key completed") |
---|
486 | if ($ADVANCED_DEBUGGING); |
---|
487 | &UPSTAT('SYNC-LOCKID-DB-SYNCH-COMPLETED-'.$lockid); |
---|
488 | |
---|
489 | # Will save to tied so reset dirty bit 3 just before |
---|
490 | $status->unset_dirty_bit(3); |
---|
491 | |
---|
492 | # Avoid check completed status |
---|
493 | } elsif ($status->dirty_bit(3)) { |
---|
494 | # A resynch is needed if tied timer has reached a time out |
---|
495 | # This can be seen as an activity delay on this status |
---|
496 | my $resynch = $timeout - $status->is_tied_timer ; |
---|
497 | &MAXMINSTAT('SYNC-LOCKID-FINISHED-TIMER-'.$lockid,$resynch); |
---|
498 | if ( $resynch > 0 ) { |
---|
499 | $resynch_needed ++ ; |
---|
500 | $resynch_list->{$key} = $status->is_tied_timer ; |
---|
501 | } |
---|
502 | } |
---|
503 | |
---|
504 | } else { |
---|
505 | &Debug("Synchro $lockid to DB for $key done at rev" . |
---|
506 | $status->db_revision) |
---|
507 | if ($ADVANCED_DEBUGGING); |
---|
508 | |
---|
509 | # Still set it to resynchronize but don't force it now |
---|
510 | $resynch_list->{$key} = $status->is_tied_timer ; |
---|
511 | } |
---|
512 | |
---|
513 | } else { |
---|
514 | &UPSTAT('SYNC-LOCKID-BAD-DB-SYNCH-'.$lockid); |
---|
515 | &Debug("Bad synchronization of $lockid $key status to DB"); |
---|
516 | } |
---|
517 | |
---|
518 | # We should check again this status until finished |
---|
519 | &in_expected_sync_list( $lockid, $key ) if ($status->dirty_bit(3)); |
---|
520 | |
---|
521 | # Be sure to only save when job is really finished |
---|
522 | if ($mode and $status->is_finished) { |
---|
523 | # We can update DBM with current SID |
---|
524 | &Debug("Updating $key in $lockid tied hash with sid " . |
---|
525 | $status->get_sid_key) |
---|
526 | if ($ADVANCED_DEBUGGING); |
---|
527 | |
---|
528 | unless ($status->save_tied('not a revision')) { |
---|
529 | &Debug("Can't update tied status $key in $lockid mem hash: $!"); |
---|
530 | # We shouldn't continue to update now, but keep in mind what we |
---|
531 | # have to do, so release the ressource very quickly |
---|
532 | &UPSTAT('SYNC-LOCKID-DELAY-DBM-SYNCH-'.$lockid); |
---|
533 | last ; |
---|
534 | } |
---|
535 | |
---|
536 | # Update recheck hash |
---|
537 | delete $resynch_list->{$key}; |
---|
538 | |
---|
539 | # Don't keep tied hash too much time so don't write too much status |
---|
540 | last if ( $status_count > 4 ); |
---|
541 | |
---|
542 | } else { |
---|
543 | # Also control timing when not gdbm writer |
---|
544 | # |
---|
545 | last if ( &_micro_timing(1) |
---|
546 | and $long_processing++ > $max_long_processing ); |
---|
547 | } |
---|
548 | } |
---|
549 | |
---|
550 | # Inject pending keys |
---|
551 | &sync_list_inject_again( $lockid, \@keys ) if @keys ; |
---|
552 | &sync_list_inject_again( $lockid, \@too_quick ) if @too_quick ; |
---|
553 | |
---|
554 | &MAXSTAT('SYNC-LOCKID-COUNTED-STATUS',$status_count); |
---|
555 | &MAXSTAT('SYNC-LOCKID-RESYNCH-NEEDED',$resynch_needed); |
---|
556 | |
---|
557 | return $resynch_needed ; |
---|
558 | } |
---|
559 | |
---|
560 | sub sync_dbm_to_db { |
---|
561 | # This API checks any available jobstatus DBM file and returns a reference |
---|
562 | # to a hash agregation of any Status object found |
---|
563 | &TIMESTAT('SYNC-DBM-TO-DB'); &UPSTAT('SYNC-DBM-TO-DB'); |
---|
564 | |
---|
565 | my %DBMS = () ; |
---|
566 | my %recheck = () ; |
---|
567 | |
---|
568 | # Get the list of available DBM file with the current base |
---|
569 | # The list is a hash which LOCKIDs as keys |
---|
570 | my $base = &dbm_base ; |
---|
571 | my $base_re = qr/^$base(.+)$/ ; |
---|
572 | %DBMS = map { $_ =~ $base_re ; $1 => 1 } |
---|
573 | grep { ! -d $_ } grep { ! /\.LCK$/ } glob( $base . '*' ) ; |
---|
574 | |
---|
575 | # Initialize timing check to not overload the computer |
---|
576 | &_micro_timing( 0, $USLEEP >> 1 ); # MAXTIME = USLEEP / 2 |
---|
577 | |
---|
578 | my $sync_count = scalar(keys(%DBMS)); |
---|
579 | my $retries = -1 ; |
---|
580 | |
---|
581 | # 2. Read each files and updates our agregation hash |
---|
582 | while (( $sync_count or keys(%recheck)) and $retries++ < 10 ) { |
---|
583 | my @lockids = grep { $DBMS{$_} } keys(%DBMS) ; |
---|
584 | push @lockids, keys(%recheck) unless ( @lockids and $retries < 10 ); |
---|
585 | |
---|
586 | # Leave loop when nothing's to do |
---|
587 | last unless (@lockids); |
---|
588 | |
---|
589 | foreach my $lockid ( @lockids ) { |
---|
590 | &UPSTAT('SYNC-DBM-LOCKID-'.$lockid); |
---|
591 | |
---|
592 | # Check to reopen gdbm as writer |
---|
593 | my $db_mode = 0 ; |
---|
594 | if (exists($recheck{$lockid})) { |
---|
595 | &UPSTAT('SYNC-DBM-AS-WRITER-'.$lockid); |
---|
596 | $db_mode = 1 ; |
---|
597 | delete $recheck{$lockid} ; |
---|
598 | } |
---|
599 | |
---|
600 | # Get the lock on tie file updating %TIED_STATUS reference |
---|
601 | my $is_tied = &tie_status_hash($lockid, $db_mode) ; |
---|
602 | |
---|
603 | # Check we got expected mode |
---|
604 | unless ( $db_mode == $CURRENTMODE ) { |
---|
605 | &UPSTAT('SYNC-DBM-LOCKID-'.$lockid.'-ERROR-MODE-'.$db_mode); |
---|
606 | next ; |
---|
607 | } |
---|
608 | |
---|
609 | # Really re-sync if tied |
---|
610 | if (defined($is_tied)) { |
---|
611 | &TIMESTAT('SYNC-DBM-LOCKID-'.$lockid.'-'.$db_mode); |
---|
612 | |
---|
613 | $DBMS{$lockid} = 0 ; |
---|
614 | $sync_count -- ; |
---|
615 | |
---|
616 | $recheck{$lockid} = 1 |
---|
617 | if (&sync_lockid( $lockid, $db_mode )); |
---|
618 | |
---|
619 | # Untie the hash after check to clean it |
---|
620 | undef $is_tied ; |
---|
621 | untie %TIED_STATUS ; |
---|
622 | |
---|
623 | &TIMESTAT('SYNC-DBM-LOCKID-'.$lockid.'-'.$db_mode); |
---|
624 | |
---|
625 | # Try to clean some entries in tied hash |
---|
626 | &_tiehash_cleaner($lockid) ; |
---|
627 | } |
---|
628 | |
---|
629 | # Anyway unlock the dbm file |
---|
630 | &dbm_unlock($lockid); |
---|
631 | } |
---|
632 | |
---|
633 | # Sleep a little if we couldn't be able to read a GDBM as other process |
---|
634 | # can access it, unless resynch is needed |
---|
635 | if ( $sync_count > 0 ) { |
---|
636 | &Debug("Sleeping as some status has not been kept"); |
---|
637 | &UPSTAT('SYNC-DBM-BAD-SYNC-COUNT'); |
---|
638 | usleep $USLEEP ; |
---|
639 | } |
---|
640 | } |
---|
641 | |
---|
642 | # Compute few service statistics |
---|
643 | &MAXSTAT('SYNC-DBM-RETRY-SYNC',$retries) if ($retries); |
---|
644 | &TIMESTAT('SYNC-DBM-TO-DB'); |
---|
645 | |
---|
646 | # Then clean our cache |
---|
647 | &cache_cleaner(); |
---|
648 | |
---|
649 | return $sync_count ; |
---|
650 | } |
---|
651 | |
---|
652 | my @micro_timer = ( 0, 0, 0 ) ; |
---|
653 | sub _micro_timing { |
---|
654 | my $flag = shift ; |
---|
655 | my @time = &gettimeofday() ; # Get current timer |
---|
656 | my $time = int( $time[0] * 1000000 + $time[1] ) ; |
---|
657 | # First call with zero flag make timer initialization |
---|
658 | if ($flag) { |
---|
659 | my $delta = $time - $micro_timer[0] ; |
---|
660 | # Exit if timer is not reached |
---|
661 | return 1 unless ( $delta > $micro_timer[2]); |
---|
662 | &MAXSTAT($LOCKID.'-MICRO-TIMING-ON-DELTA',$delta); |
---|
663 | &UPSTAT($LOCKID.'-USLEEP-'.$micro_timer[2].'-IN-MICRO-TIMING'); |
---|
664 | return usleep 1000 && 0 unless ( $time < $micro_timer[1] ); |
---|
665 | usleep $micro_timer[2] ; |
---|
666 | |
---|
667 | } else { |
---|
668 | # USLEEP * 4 should not be reached, set this as timeout |
---|
669 | $micro_timer[1] = $time + $USLEEP << 2 ; |
---|
670 | # Second argument is then the maxtime to sleep in later calls |
---|
671 | $micro_timer[2] = shift || $USLEEP ; |
---|
672 | } |
---|
673 | return $micro_timer[0] = $time ; # Update timer |
---|
674 | } |
---|
675 | |
---|
676 | sub getstatus_from_db { |
---|
677 | # This API get each jobstatus found in DB |
---|
678 | # It populates the local cache hash and returns a reference to this hash |
---|
679 | # Used from service-lib.pl in afp2print Webmin module |
---|
680 | |
---|
681 | # Some filters can be passed |
---|
682 | my $lockid_filter = shift || "" ; |
---|
683 | # Next are references |
---|
684 | my $jname_filter = shift || "" ; # Can be a ref regex |
---|
685 | my $day_filter = shift || "" ; |
---|
686 | my $status_filter = shift || "" ; # Can be a ref regex |
---|
687 | my $sql = shift || "" ; # Can be a hash ref |
---|
688 | |
---|
689 | unless (@_==3) { |
---|
690 | return &Error("DBI configuration not provided with: '@_'"); |
---|
691 | } |
---|
692 | # Update DBI access configuration |
---|
693 | $DBI_DSN = shift ; |
---|
694 | $DBI_USER = shift ; |
---|
695 | $DBI_PASSWD = shift ; |
---|
696 | |
---|
697 | # Can be better called with a call-back |
---|
698 | my $filter = ref($lockid_filter) =~ /^CODE$/ ? $lockid_filter : sub { 0 }; |
---|
699 | $lockid_filter = "" if (&$filter); |
---|
700 | |
---|
701 | my %filtered = () ; |
---|
702 | my @filter = $filter ? () : (\$jname_filter,\$day_filter,\$status_filter); |
---|
703 | |
---|
704 | my $status = new A2P::Status( \%STATUS, \%TIED_STATUS ) ; |
---|
705 | |
---|
706 | # Remove this first from cache as it is just an API accessor |
---|
707 | $status->remove_from_cache ; |
---|
708 | |
---|
709 | while (defined($status) and $status and $status->get_next_from_db($sql)) { |
---|
710 | next unless $status->is_job ; |
---|
711 | # Insert a copy in the cache for our JOB name |
---|
712 | $STATUS{$status->is_job} = $status->clone |
---|
713 | unless ((@filter and $status->is_filtered(@filter)) |
---|
714 | or (&$filter and &$filter($status))); |
---|
715 | } |
---|
716 | |
---|
717 | # Don't keep this entry as not a status |
---|
718 | delete $STATUS{__SID__} ; |
---|
719 | |
---|
720 | return \%STATUS ; |
---|
721 | } |
---|
722 | |
---|
723 | sub is_status { |
---|
724 | return 0 unless @_ ; |
---|
725 | |
---|
726 | # Check if argument is an A2P::Status object |
---|
727 | return ref($_[0]) =~ /^A2P::Status$/ ? 1 : 0 ; |
---|
728 | } |
---|
729 | |
---|
730 | sub is_tied_status { |
---|
731 | return 0 unless @_ ; |
---|
732 | &TIMESTAT('IS-TIED-STATUS?'); |
---|
733 | |
---|
734 | # Check if key/value designed by |
---|
735 | my $key = shift ; |
---|
736 | |
---|
737 | my $is_status = 0 ; |
---|
738 | |
---|
739 | if ( $key =~ /_rev$/ or exists($TIED_STATUS{$TIED_STATUS{$key}}) |
---|
740 | or ( $TIED_STATUS{$key} =~ /^\d+$/ |
---|
741 | and exists($TIED_STATUS{'_SID_'.$TIED_STATUS{$key}}) ) ) { |
---|
742 | # Return false if key is a rev key |
---|
743 | # Check also if its a reference to another key and then return false |
---|
744 | &UPSTAT('IS-TIED-STATUS-NO'); |
---|
745 | |
---|
746 | } elsif ( $key =~ /^_SID_\d+$/ |
---|
747 | or $TIED_STATUS{$key} =~ _freezed_status_re ) { |
---|
748 | $is_status = 1 ; |
---|
749 | &UPSTAT('IS-TIED-STATUS-YES'); |
---|
750 | |
---|
751 | } else { |
---|
752 | &UPSTAT('IS-TIED-STATUS-NO-2'); |
---|
753 | } |
---|
754 | |
---|
755 | return $is_status ; |
---|
756 | } |
---|
757 | |
---|
758 | # Private hash to help clean tiehashs from a2p-status |
---|
759 | my %th_cleaner = ( TIMER => {}, LIST => {} ) ; |
---|
760 | my %lost = () ; |
---|
761 | sub _tiehash_cleaner { |
---|
762 | # Still return if MAXAGE is not set (dangerous) |
---|
763 | return 0 unless ( $STATUS_MAXAGE ) ; |
---|
764 | |
---|
765 | my $lockid = shift ; |
---|
766 | |
---|
767 | # Get the current processed list |
---|
768 | my $list = exists($th_cleaner{LIST}->{$lockid}) ? |
---|
769 | $th_cleaner{LIST}->{$lockid} : [] ; |
---|
770 | |
---|
771 | # Return if list is empty and timer list is lower than 5 minutes, but do a |
---|
772 | # clean on the first call |
---|
773 | return 0 if ( ! @{$list} and exists($th_cleaner{TIMER}->{$lockid}) |
---|
774 | and &tv_interval($th_cleaner{TIMER}->{$lockid}) < 300 ); |
---|
775 | |
---|
776 | &UPSTAT('TH-CLEANER-API-'.$lockid); |
---|
777 | |
---|
778 | unless (@{$list}) { |
---|
779 | # Try to access tiehash as reader when preparing the list |
---|
780 | return 0 unless (defined(&tie_status_hash($lockid, 0))) ; |
---|
781 | |
---|
782 | &TIMESTAT('TH-CLEANER-INIT-'.$lockid); |
---|
783 | &UPSTAT('TH-CLEANER-INIT-API-'.$lockid); |
---|
784 | |
---|
785 | # Update timer now |
---|
786 | $th_cleaner{TIMER}->{$lockid} = [ &gettimeofday() ]; |
---|
787 | |
---|
788 | # Initialize hash keys list, being sure to only have status keys |
---|
789 | $list = [ grep { &is_tied_status($_) } keys(%TIED_STATUS) ] ; |
---|
790 | $th_cleaner{LIST}->{$lockid} = $list ; |
---|
791 | |
---|
792 | &StatusDebug(1); |
---|
793 | |
---|
794 | # This value indicates which $MAX_CACHED_STATUS we should set as conf |
---|
795 | &MAXSTAT('TH-CLEANER-INIT-COUNT-'.$lockid,scalar(@{$list})); |
---|
796 | &TIMESTAT('TH-CLEANER-INIT-'.$lockid); |
---|
797 | |
---|
798 | untie %TIED_STATUS ; |
---|
799 | |
---|
800 | # Still return anyway |
---|
801 | return 0 ; |
---|
802 | } |
---|
803 | |
---|
804 | &TIMESTAT('TH-CLEANER-'.$lockid); |
---|
805 | |
---|
806 | # Try to access tiehash as writer |
---|
807 | &tie_status_hash($lockid, 1) ; |
---|
808 | |
---|
809 | # Short cut the processing loop in case we are not writer |
---|
810 | my $maxcount = &cansavetied() ? 10 : 0 ; |
---|
811 | |
---|
812 | # Only process a limited count of jobs by call |
---|
813 | my $count = 0 ; |
---|
814 | while ( @{$list} and $count ++ < $maxcount ) { |
---|
815 | my $job = shift @{$list} ; |
---|
816 | |
---|
817 | # Skip still removed entry |
---|
818 | next unless (exists($TIED_STATUS{$job})); |
---|
819 | |
---|
820 | # Reget this status from/into the cache |
---|
821 | my $status = new A2P::Status( \%STATUS, \%TIED_STATUS , $job ) |
---|
822 | or next ; |
---|
823 | |
---|
824 | # Check the age |
---|
825 | &MAXSTAT('TH-CLEANER-STATUS-REAL-AGE-'.$lockid,$status->real_age); |
---|
826 | if ( $status->is_done_and_timer_aged ) { |
---|
827 | &StatusDebug("Cleaning $job in tied hash"); |
---|
828 | $status->remove_from_cache ; |
---|
829 | $status->remove_from_tied_hash ; |
---|
830 | &UPSTAT('TH-CLEANER-STATUS-CLEANED-'.$lockid); |
---|
831 | } |
---|
832 | } |
---|
833 | |
---|
834 | &TIMESTAT('TH-CLEANER-'.$lockid); |
---|
835 | |
---|
836 | # Check also to shrink GDBM some time |
---|
837 | &_shrink_gdbm_file($lockid) if $maxcount ; |
---|
838 | |
---|
839 | # Untie before leaving |
---|
840 | untie %TIED_STATUS ; |
---|
841 | |
---|
842 | 1 ; |
---|
843 | } |
---|
844 | |
---|
845 | my $cache_timer = undef ; # Timer to handle cache check |
---|
846 | my @cache_checklist = () ; |
---|
847 | my @cache_ages = () ; |
---|
848 | my %age_checklist = () ; |
---|
849 | my $cache_older = 0 ; |
---|
850 | sub cache_cleaner { |
---|
851 | # Clean cache object each minute (objects will be reloaded from |
---|
852 | # tied file if deleted from cache) |
---|
853 | return 0 if ( ! $STATUS_CACHE_MAXAGE |
---|
854 | or ( ! @_ and defined($cache_timer) and &tv_interval($cache_timer)< 60 ) |
---|
855 | # Also return it known max cache age |
---|
856 | or ( $cache_older and 1000*time-$cache_older<$STATUS_CACHE_MAXAGE )); |
---|
857 | |
---|
858 | # Remove still unused keys if test case only |
---|
859 | map { delete $STATUS{$_} } grep { /^__/ } keys(%STATUS) if @_ ; |
---|
860 | |
---|
861 | &UPSTAT('STATUS-OBJECT-CACHE-CLEANER-API'); |
---|
862 | |
---|
863 | # Arguments should only used for testing purpose |
---|
864 | my $max_loops = shift || 10 ; |
---|
865 | |
---|
866 | unless (@cache_checklist) { |
---|
867 | &TIMESTAT('CACHE-CLEANER-INIT'); |
---|
868 | my @keys = keys(%STATUS) ; |
---|
869 | &MAXSTAT('CACHE-KEYS-COUNT',scalar(@keys)); |
---|
870 | |
---|
871 | # Be sure to only have status keys, and filter duplicate references |
---|
872 | @cache_checklist = () ; |
---|
873 | foreach my $job ( grep { &is_status($STATUS{$_}) } @keys ) { |
---|
874 | push @cache_checklist, $job |
---|
875 | unless (grep { $STATUS{$job} == $STATUS{$_} } @cache_checklist); |
---|
876 | } |
---|
877 | |
---|
878 | # Prepare a list of ages based on timers if still not done |
---|
879 | unless (keys(%age_checklist)) { |
---|
880 | %age_checklist = () ; |
---|
881 | map { push @{$age_checklist{$STATUS{$_}->timer}}, $_ } |
---|
882 | @cache_checklist ; |
---|
883 | |
---|
884 | # List the ages |
---|
885 | @cache_ages = sort(keys(%age_checklist)) ; # First is older |
---|
886 | } |
---|
887 | |
---|
888 | # Set now the timer |
---|
889 | $cache_timer = [ &gettimeofday() ] ; |
---|
890 | &StatusDebug(3); |
---|
891 | &TIMESTAT('CACHE-CLEANER-INIT'); |
---|
892 | |
---|
893 | # Return anyway |
---|
894 | return scalar(@cache_checklist) ; |
---|
895 | } |
---|
896 | |
---|
897 | my $status_count = @cache_checklist ; |
---|
898 | &MAXSTAT('STATUS-OBJECT-KEPT-IN-CACHE',$status_count); |
---|
899 | |
---|
900 | if ( $status_count > $MAX_CACHED_STATUS ) { |
---|
901 | # Manage cache size |
---|
902 | &UPSTAT('STATUS-OBJECT-MAX-CACHED-REACHED'); |
---|
903 | &TIMESTAT('CACHE-CLEANER-MAX-REACHED'); |
---|
904 | |
---|
905 | $cache_older = shift @cache_ages ; |
---|
906 | |
---|
907 | my $limit = abs($MAX_CACHED_STATUS - 10) + 1 ; # Paranoid temp limit |
---|
908 | while ( defined($cache_older) and $cache_older |
---|
909 | and $status_count >= $limit ) { |
---|
910 | my $aged = shift @{$age_checklist{$cache_older}} ; |
---|
911 | if (defined($aged) and $aged and exists($STATUS{$aged})) { |
---|
912 | &UPSTAT('CACHED-STATUS-OBJECT-EARLY-CLEANED'); |
---|
913 | $status_count -- ; |
---|
914 | $STATUS{$aged}->remove_from_cache ; |
---|
915 | } |
---|
916 | |
---|
917 | unless (@{$age_checklist{$cache_older}}) { |
---|
918 | # Don't forget to forget that age |
---|
919 | delete $age_checklist{$cache_older} ; |
---|
920 | $cache_older = shift @cache_ages ; |
---|
921 | } |
---|
922 | } |
---|
923 | |
---|
924 | # Filter on existing keys |
---|
925 | @cache_checklist = grep { exists($STATUS{$_}) } @cache_checklist ; |
---|
926 | |
---|
927 | &TIMESTAT('CACHE-CLEANER-MAX-REACHED'); |
---|
928 | # Return anyway |
---|
929 | return $status_count ; |
---|
930 | } |
---|
931 | |
---|
932 | &TIMESTAT('CACHE-CLEANER'); |
---|
933 | |
---|
934 | my $count = 0 ; |
---|
935 | # Don't check too much cached values at a time |
---|
936 | while ( @cache_checklist and $count ++ < $max_loops ) { |
---|
937 | my $job = shift @cache_checklist ; |
---|
938 | # Avoid cleaning not job or lost keys |
---|
939 | next unless (exists($STATUS{$job}) and &is_status($STATUS{$job})); |
---|
940 | if ( defined($STATUS{$job}->check_cached_aged) ) { |
---|
941 | &UPSTAT('CACHED-STATUS-OBJECT-KEPT'); |
---|
942 | } else { |
---|
943 | &UPSTAT('CACHED-STATUS-OBJECT-CLEANED'); |
---|
944 | } |
---|
945 | } |
---|
946 | |
---|
947 | &MAXSTAT('CACHED-STATUS-OBJECT-CHECKED',$count); |
---|
948 | &TIMESTAT('CACHE-CLEANER'); |
---|
949 | return $count ; # Only used in tests |
---|
950 | } |
---|
951 | |
---|
952 | my @pending = () ; |
---|
953 | sub tied_update_status { |
---|
954 | # Can be called without argument to compute any pending status |
---|
955 | return unless (@_ or @pending); |
---|
956 | |
---|
957 | my $Job = shift ; |
---|
958 | my $Step = shift ; |
---|
959 | my $Status = shift ; |
---|
960 | my $Infos = shift || {} ; |
---|
961 | |
---|
962 | push @pending , [ $Job, $Step, $Status, $Infos ] |
---|
963 | if (defined($Job)); |
---|
964 | |
---|
965 | # 1. We need to tie our hash to GDBM file before continuing |
---|
966 | my $retries = 0 ; |
---|
967 | my $timeout = [ &gettimeofday() ] ; |
---|
968 | $! = 0 ; |
---|
969 | while (!(defined(&tie_status_hash($LOCKID)) and &cansavetied)) { |
---|
970 | ($! == 11)? &UPSTAT('BUSY-TIED-HASH'):&Warn("Can't lock GDBM file: $!"); |
---|
971 | $! = 0 ; |
---|
972 | &dbm_unlock(); |
---|
973 | tied(%TIED_STATUS) and untie %TIED_STATUS ; |
---|
974 | &Warn("Can't unlock GDBM file: $!") if $! ; |
---|
975 | ++ $retries and &MAXSTAT('FORCED-UPDATE-STATUS-RETRY',$retries); |
---|
976 | if ( &tv_interval($timeout) > 60 ) { |
---|
977 | &UPSTAT('HASH-NOT-TIED-AFTER-60s'); |
---|
978 | last ; |
---|
979 | } |
---|
980 | usleep ( $retries < 5 ? $USLEEP >> 1 : |
---|
981 | ($retries < 10 ? $retries * $USLEEP : 10 * $USLEEP )); |
---|
982 | $! = 0 ; |
---|
983 | } |
---|
984 | |
---|
985 | while (@pending) { |
---|
986 | my $ref = shift @pending ; |
---|
987 | ( $Job, $Step, $Status, $Infos ) = @{$ref} ; |
---|
988 | |
---|
989 | # Strip any number at the end of job name |
---|
990 | $Job =~ s/-\d+$// ; |
---|
991 | |
---|
992 | # 2. Get the status object |
---|
993 | my $jobstatus = new A2P::Status( \%STATUS, \%TIED_STATUS , $Job ) ; |
---|
994 | |
---|
995 | unless (defined($jobstatus) and $jobstatus) { |
---|
996 | &Warn("Can't update Job status of $Job"); |
---|
997 | unshift @pending, $ref ; |
---|
998 | last ; |
---|
999 | } |
---|
1000 | |
---|
1001 | # 3. Updating object status |
---|
1002 | &StatusDebug(4); |
---|
1003 | &Warn("$Job status at step $Step to $Status not updated") |
---|
1004 | unless ( $jobstatus->step_status($Step,$Status) ); |
---|
1005 | |
---|
1006 | # 4. Update object with infos |
---|
1007 | &StatusDebug(5); |
---|
1008 | $jobstatus->infos($Infos); |
---|
1009 | |
---|
1010 | # 5. Update object timer to reset its cache age |
---|
1011 | $jobstatus->cached ; |
---|
1012 | |
---|
1013 | # 6. Saving tied objects |
---|
1014 | &StatusDebug(6); |
---|
1015 | $jobstatus->save_tied ; |
---|
1016 | } |
---|
1017 | |
---|
1018 | # 7. Then we can untie our hash if really tied |
---|
1019 | &StatusDebug(7); |
---|
1020 | untie %TIED_STATUS ; |
---|
1021 | |
---|
1022 | # 8. Also unlock DBM file if locked |
---|
1023 | &dbm_unlock(); |
---|
1024 | |
---|
1025 | # Keep internal stats |
---|
1026 | if (@pending) { |
---|
1027 | &DebugPendingQueue(); |
---|
1028 | $STATS{'PENDING-JOBSTATUS'} = join(';',map { "@{$_}" } @pending) ; |
---|
1029 | |
---|
1030 | } elsif (exists($STATS{'PENDING-JOBSTATUS'})) { |
---|
1031 | &MAXSTAT('PENDING-JOBSTATUS-COUNT',scalar(@pending)); |
---|
1032 | delete $STATS{'PENDING-JOBSTATUS'} ; |
---|
1033 | } |
---|
1034 | |
---|
1035 | return \%TIED_STATUS ; |
---|
1036 | } |
---|
1037 | |
---|
1038 | my $debug_pending_timer ; |
---|
1039 | sub DebugPendingQueue { |
---|
1040 | return unless ($ADVANCED_DEBUGGING); |
---|
1041 | |
---|
1042 | # Handle timer, debug only at max each second |
---|
1043 | return unless (defined($debug_pending_timer) |
---|
1044 | and &tv_interval($debug_pending_timer) > 1); |
---|
1045 | $debug_pending_timer = [ &gettimeofday() ] ; |
---|
1046 | |
---|
1047 | my %pendings = () ; |
---|
1048 | |
---|
1049 | # Analyse list |
---|
1050 | map { |
---|
1051 | my ( $n, $s, $S, $I ) = @{$_} ; |
---|
1052 | $pendings{$n} = { STEPMIN => 12 , STEPMAX => 0 , STATUS => '' } |
---|
1053 | unless (exists($pendings{$n})); |
---|
1054 | $pendings{$n}->{STEPMIN} = $s if ( $s < $pendings{$n}->{STEPMIN}); |
---|
1055 | $pendings{$n}->{STEPMAX} = $s if ( $s > $pendings{$n}->{STEPMAX}); |
---|
1056 | $pendings{$n}->{STEP} = $s, $pendings{$n}->{STATUS} = $S |
---|
1057 | if ( $S eq 'A' or ( $pendings{$n}->{STATUS} ne 'A' |
---|
1058 | and $pendings{$n}->{STATUS} ne 'o' )); |
---|
1059 | } @pending ; |
---|
1060 | |
---|
1061 | my @pendings = keys(%pendings) ; |
---|
1062 | &StatusDebug(@pendings." pending status updates"); |
---|
1063 | |
---|
1064 | my @abterms = grep { $pendings{$_}->{STATUS} eq 'A' } @pendings ; |
---|
1065 | if (@abterms) { |
---|
1066 | &StatusDebug(@abterms." pending ABTERM status update (@abterms)"); |
---|
1067 | map { &StatusDebug("$_ ABTERM: status steps: ".$pendings{$_}->{STEPMIN}. |
---|
1068 | " - ".$pendings{$_}->{STEPMAX}.(exists($pendings{$_}->{STEP})? |
---|
1069 | " ; ABTERM Step: ".$pendings{$_}->{STEP} : "")); |
---|
1070 | delete $pendings{$_} ; |
---|
1071 | } @abterms ; |
---|
1072 | } |
---|
1073 | |
---|
1074 | # Get again list after ABTERM keys deletion |
---|
1075 | @pendings = keys(%pendings) ; |
---|
1076 | if (@pendings) { |
---|
1077 | &StatusDebug(@pendings." pending ok status update:"); |
---|
1078 | map { &StatusDebug("$_: status steps: ".$pendings{$_}->{STEPMIN}. |
---|
1079 | " - ".$pendings{$_}->{STEPMAX}); |
---|
1080 | } @abterms ; |
---|
1081 | } |
---|
1082 | } |
---|
1083 | |
---|
1084 | END { |
---|
1085 | # Try to purge pending status updates |
---|
1086 | &tied_update_status ; |
---|
1087 | |
---|
1088 | if ($ADVANCED_DEBUGGING) { |
---|
1089 | foreach my $mesg (keys(%MESG)) { |
---|
1090 | next unless ( $MESG{$mesg}->[0] > 1 ); |
---|
1091 | $MESG{$mesg}->[0] -- ; |
---|
1092 | $MESG{$mesg}->[1] = [ 0, 0 ]; |
---|
1093 | &StatusDebug($mesg); |
---|
1094 | } |
---|
1095 | } |
---|
1096 | |
---|
1097 | # Save in_expected sync lists in SharedList lists |
---|
1098 | foreach my $lockid (keys(%{$sync_list[1]})) { |
---|
1099 | my @expected = keys(%{$sync_list[1]->{$lockid}}); |
---|
1100 | my $shared = &SharedList( $lockid, 'forced' ); |
---|
1101 | push @{$shared}, @expected if ( ref($shared) =~ /^ARRAY/i ); |
---|
1102 | &FreeSharedList( $lockid ); |
---|
1103 | } |
---|
1104 | } |
---|
1105 | |
---|
1106 | &Debug("Module " . __PACKAGE__ . " v$VERSION loaded"); |
---|
1107 | |
---|
1108 | 1; |
---|