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: Status.pm 3 2007-10-18 16:20:19Z guillaume $ |
---|
21 | # |
---|
22 | # Class to implement one job status object handling its tied version |
---|
23 | # |
---|
24 | |
---|
25 | package A2P::Status ; |
---|
26 | |
---|
27 | use strict; |
---|
28 | use Storable qw( freeze thaw ); |
---|
29 | use Time::HiRes qw( usleep ); |
---|
30 | use A2P::Globals ; |
---|
31 | use A2P::Syslog ; |
---|
32 | use A2P::Tools qw( SharedList FreeSharedList ms ); |
---|
33 | use A2P::DB qw( job_status_update is_job_status_updated get_next_jobstatus |
---|
34 | job_status_delete ); |
---|
35 | |
---|
36 | BEGIN { |
---|
37 | our $VERSION = sprintf "%s", q$Rev: 1158 $ =~ /(\d[0-9.]+)\s+/ ; |
---|
38 | } |
---|
39 | our $VERSION ; |
---|
40 | |
---|
41 | # Set initial status constant to default array at compilation |
---|
42 | sub INTIAL_STATUS { split(//,'o__00000000__') } |
---|
43 | |
---|
44 | my $CACHE = {} ; # Status object cache |
---|
45 | my $TIEHASH = {} ; # Tied hash |
---|
46 | my $DB = {} ; # Status DB informations |
---|
47 | my $SID_INDEX = 0 ; # Index to initialize status unique ID, only in a2p-status |
---|
48 | my %MESG = () ; # Used in StatusDebug to avoid same messages |
---|
49 | |
---|
50 | ### Private members related to SID management ### |
---|
51 | # Reference of sid cache list |
---|
52 | sub SID_CACHE { defined($CACHE->{__SID__}) ? $CACHE->{__SID__} : |
---|
53 | ( $CACHE->{__SID__} = {} ) } |
---|
54 | # Only call _get_sid_tied_key when we are sure first arg is a number |
---|
55 | sub _get_sid_tied_key { '_SID_' . (@_ ? $_[0] : "" ) } |
---|
56 | my $MATCH_SID_TIED_KEY = qr/^_SID_(\d+)$/ ; |
---|
57 | # Revision keys extension |
---|
58 | sub _rev_ext { '_rev' } |
---|
59 | sub _rev_ext_re { qr/_rev$/ } |
---|
60 | ################################################# |
---|
61 | |
---|
62 | sub _is_tie_writer { |
---|
63 | # Status object must not be used before this key is set in cache |
---|
64 | return ( tied(%$TIEHASH) and defined($CACHE->{__GDBM_WRITER__}) |
---|
65 | and $CACHE->{__GDBM_WRITER__} ); |
---|
66 | } |
---|
67 | |
---|
68 | sub new { |
---|
69 | my $class = shift ; |
---|
70 | my $self = undef ; |
---|
71 | |
---|
72 | # Return if CACHE and TIEHASH are not hash |
---|
73 | return $self |
---|
74 | unless (ref($_[0]) =~ /^HASH/ and ref($_[1]) =~ /^HASH/); |
---|
75 | |
---|
76 | &TIMESTAT('STATUS-GET-NEW'); |
---|
77 | |
---|
78 | $CACHE = shift ; |
---|
79 | $TIEHASH = shift ; |
---|
80 | my $job = shift || 'noname' ; |
---|
81 | |
---|
82 | # Try to get the status from CACHE |
---|
83 | if (defined(SID_CACHE->{$job})) { |
---|
84 | $self = SID_CACHE->{$job}->check_cached_aged ; |
---|
85 | |
---|
86 | } elsif (defined($CACHE->{$job})) { |
---|
87 | $self = $CACHE->{$job}->check_cached_aged ; |
---|
88 | } |
---|
89 | |
---|
90 | unless (defined($self)) { |
---|
91 | # Job not in cache, prepare to check tied hash by constructing a |
---|
92 | # minimal object |
---|
93 | $self = { JOB => $job, INITIAL => $job } ; |
---|
94 | bless $self , $class ; |
---|
95 | $self->_set_defaults ; |
---|
96 | } |
---|
97 | |
---|
98 | $self->is_job($job); |
---|
99 | |
---|
100 | # Get ourself from tied hash if I was updated in tied hash |
---|
101 | $self = $self->compared_with_one_from_tiehash ; |
---|
102 | |
---|
103 | # Keep references in cache when not cached |
---|
104 | $self->cached unless ($self->is_cached); |
---|
105 | |
---|
106 | # Check SID: Set to 0 by default unless in a2p-status |
---|
107 | $self->set_sid_index(&_found_sid) unless (defined($self->get_sid_index)); |
---|
108 | |
---|
109 | # Delete initial tag for newly created object used as ident when destroyed |
---|
110 | if (exists($self->{INITIAL})) { |
---|
111 | #&StatusDebug("new Status object v$VERSION created for $job"); |
---|
112 | delete $self->{INITIAL} ; |
---|
113 | } |
---|
114 | |
---|
115 | &TIMESTAT('STATUS-GET-NEW'); |
---|
116 | return $self ; |
---|
117 | } |
---|
118 | |
---|
119 | sub _set_defaults { |
---|
120 | # Be careful, some defaults must only be set the first time |
---|
121 | my $self = shift ; |
---|
122 | $self->{JOB} = "noname" unless (defined($self->{JOB})); |
---|
123 | $self->{AFP} = $self->is_job unless (defined($self->{AFP})); |
---|
124 | $self->{JOBID} = "" unless (defined($self->{JOBID})); |
---|
125 | $self->{STEP} = 2 ; # We are still at step when jobstatus is created |
---|
126 | $self->{STATE} = [ INTIAL_STATUS ] ; |
---|
127 | $self->{LOCKID} = $LOCKID ; |
---|
128 | $self->{DAY} = 19700101 ; |
---|
129 | $self->{BORN} = 0 unless (exists($self->{BORN})); |
---|
130 | $self->{REV} = 0 unless (defined($self->{REV})); |
---|
131 | $self->{TIMER} = 0 unless (defined($self->{TIMER})); |
---|
132 | map { $self->unset_dirty_bit($_) } 1..16 ; # Reset dirty bits |
---|
133 | } |
---|
134 | |
---|
135 | sub set_sid_index { # SID must set as a number |
---|
136 | my $self = shift ; |
---|
137 | my $sid = shift ; |
---|
138 | if (defined($sid) and $sid =~ /^\d+$/) { |
---|
139 | $self->{SID} = $sid ; |
---|
140 | |
---|
141 | # Update our predictive internal SID index counter |
---|
142 | &_found_sid( $sid ); |
---|
143 | |
---|
144 | } elsif (exists($self->{SID})) { |
---|
145 | delete $self->{SID} ; |
---|
146 | } |
---|
147 | } |
---|
148 | |
---|
149 | sub get_sid_index { # Must return a number as SID |
---|
150 | return defined($_[0]->{SID}) ? $_[0]->{SID} : 0 ; |
---|
151 | } |
---|
152 | |
---|
153 | sub get_sid_key { |
---|
154 | # Return an unique SID key for the tied hash |
---|
155 | my $self = shift ; |
---|
156 | return ( $_[0] =~ /^\d+$/ ) ? _get_sid_tied_key($_[0]) : $_[0] |
---|
157 | if (@_ and $_[0]); |
---|
158 | # self->AFP is the default SID key |
---|
159 | return $self->get_sid_index ? |
---|
160 | _get_sid_tied_key($self->get_sid_index) : ( shift || $self->{AFP} ) ; |
---|
161 | } |
---|
162 | |
---|
163 | sub get_sid_version_key { |
---|
164 | return (defined($_[1]) ? |
---|
165 | ( $_[1] =~ /^\d+$/ ? $_[0]->get_sid_key($_[1]) : $_[1] ) : |
---|
166 | $_[0]->get_sid_key ) . _rev_ext ; |
---|
167 | } |
---|
168 | |
---|
169 | sub _is_revision_key { |
---|
170 | return $_[0] =~ _rev_ext_re ; |
---|
171 | } |
---|
172 | |
---|
173 | sub _found_sid { |
---|
174 | # API only useful in a2p-status |
---|
175 | return ( $_[0] > $SID_INDEX ? $SID_INDEX = shift : shift ) |
---|
176 | if (@_ and $_[0] =~ /^\d+$/); |
---|
177 | return 0 unless ($SID_INDEX); |
---|
178 | $SID_INDEX ++ ; |
---|
179 | return (defined(SID_CACHE->{$SID_INDEX}) |
---|
180 | or defined($TIEHASH->{_get_sid_tied_key($SID_INDEX)})) ? |
---|
181 | &_found_sid : $SID_INDEX ; |
---|
182 | } |
---|
183 | |
---|
184 | sub current_in_tie_sid_key { |
---|
185 | my $self = shift ; |
---|
186 | my $sid = $self->is_job ; |
---|
187 | my $key = 0 ; |
---|
188 | my %REFS = () ; # Reference counters to avoid infinite loops |
---|
189 | |
---|
190 | # Retrieve the tiehash SID as a number (it is 0 if not a SID number) |
---|
191 | while ($sid and $sid !~ /^\d+$/ and |
---|
192 | (!defined($REFS{$sid}) or $REFS{$sid} < 2)) { |
---|
193 | if ($sid =~ $MATCH_SID_TIED_KEY) { |
---|
194 | # Extract SID from key |
---|
195 | $sid = $1 ; |
---|
196 | |
---|
197 | } else { |
---|
198 | $REFS{$sid} ++ ; # Update reference counter to avoid infinite loops |
---|
199 | # SID is a reference to another key or SID is invalid |
---|
200 | if (defined($TIEHASH->{$sid})) { |
---|
201 | if (defined($TIEHASH->{$self->get_sid_version_key($sid)})) { |
---|
202 | $key = $sid ; |
---|
203 | $sid = 0 ; |
---|
204 | last ; |
---|
205 | |
---|
206 | } else { |
---|
207 | $sid = $TIEHASH->{$sid} ; |
---|
208 | } |
---|
209 | |
---|
210 | } else { |
---|
211 | $sid = 0 ; |
---|
212 | } |
---|
213 | } |
---|
214 | } |
---|
215 | |
---|
216 | $key = $self->get_sid_key($sid) unless ($key); |
---|
217 | |
---|
218 | # If not a numbered SID, we will retrieve from jobname |
---|
219 | #&StatusDebug("Status SID for ".$self->is_job." has changed". |
---|
220 | # ($self->get_sid_index?" from ".$self->get_sid_index:"")." to $sid") |
---|
221 | # if ($sid and $self->get_sid_index != $sid); |
---|
222 | |
---|
223 | return $key ; |
---|
224 | } |
---|
225 | |
---|
226 | sub compared_with_one_from_tiehash { |
---|
227 | my $self = shift ; |
---|
228 | my $job = $self->is_job ; |
---|
229 | |
---|
230 | # Retrieve the key of the object in the tied hash, needed to check version |
---|
231 | my $sidkey = $self->current_in_tie_sid_key ; |
---|
232 | |
---|
233 | if (defined($TIEHASH->{$sidkey})) { |
---|
234 | #&StatusDebug("Checking $sidkey tied version"); |
---|
235 | # 1. The revision from tied hash can be a newer version |
---|
236 | &TIMESTAT('STATUS-GET-COMPARED'); |
---|
237 | my $older = $self->is_older_than_tied($sidkey); |
---|
238 | &TIMESTAT('STATUS-GET-COMPARED'); |
---|
239 | if ( $older ) { |
---|
240 | &TIMESTAT('STATUS-GET-TIED'); |
---|
241 | &UPSTAT('HIT-TIED-STATUS'); |
---|
242 | |
---|
243 | # is_tied API must return 0 or a A2P::Status object |
---|
244 | my $newself = $self->is_tied($sidkey); |
---|
245 | if (defined($newself) and $newself) { |
---|
246 | if ($newself != $self) { |
---|
247 | #&StatusDebug("Replacing $job by tied $sidkey (" . |
---|
248 | # $newself->is_job . ") at rev. " . |
---|
249 | # $newself->get_revision ); |
---|
250 | |
---|
251 | # Don't forget to update it with current job name |
---|
252 | $newself->is_job($job); |
---|
253 | $self = $newself ; |
---|
254 | } |
---|
255 | |
---|
256 | } else { |
---|
257 | &StatusDebug("Can't get $job Status from local file"); |
---|
258 | } |
---|
259 | &TIMESTAT('STATUS-GET-TIED'); |
---|
260 | |
---|
261 | # 2. Our cached version is newer revision, we still got it |
---|
262 | } else { |
---|
263 | &UPSTAT('HIT-CACHED-STATUS'); |
---|
264 | #&StatusDebug("Keep cached '$job' status from memory at rev. " |
---|
265 | # . $self->get_revision); |
---|
266 | } |
---|
267 | } |
---|
268 | |
---|
269 | return $self ; |
---|
270 | } |
---|
271 | |
---|
272 | sub is_done_and_timer_aged { |
---|
273 | my $self = shift ; |
---|
274 | |
---|
275 | # Only set the status is aged when parameter is set and status is DONE and |
---|
276 | # the dirty bit 3 is not set (not synched in DB by a2p-status) |
---|
277 | return 0 unless ( $STATUS_MAXAGE and $self->is_done |
---|
278 | and ! $self->dirty_bit(3)); |
---|
279 | |
---|
280 | # Get the timer based age |
---|
281 | my $age = $self->is_tied_timer ? &ms() - $self->is_tied_timer : 0 ; |
---|
282 | &MAXSTAT("STATUS-TIMER-AGE",$age); |
---|
283 | return $age > $STATUS_MAXAGE ? 1 : 0 ; |
---|
284 | } |
---|
285 | |
---|
286 | sub _born { |
---|
287 | my $self = shift ; |
---|
288 | |
---|
289 | # Set day status |
---|
290 | my @time = localtime(time); |
---|
291 | $self->{DAY} = ($time[5]%100 + 2000)*10000 + ($time[4]+1) *100 + $time[3] ; |
---|
292 | |
---|
293 | # Set born time to the current millisecond from the epoch |
---|
294 | $self->{BORN} = &ms() unless (defined($self->{BORN}) and $self->{BORN}); |
---|
295 | } |
---|
296 | |
---|
297 | sub cached { |
---|
298 | &TIMESTAT('STATUS-OBJECT-CACHED'); |
---|
299 | my $self = shift ; |
---|
300 | |
---|
301 | # Update every important key in cache |
---|
302 | map { |
---|
303 | $CACHE->{$self->{$_}} = $self |
---|
304 | } grep { |
---|
305 | defined($self->{$_}) and $self->{$_} |
---|
306 | } qw{ |
---|
307 | JOB JOBID AFP |
---|
308 | }; |
---|
309 | |
---|
310 | # Check jobs reference in cache |
---|
311 | my @jobs = defined($self->{JOBS}) ? @{$self->{JOBS}} : (); |
---|
312 | map { $CACHE->{$_} = $self } grep { defined } @jobs ; |
---|
313 | |
---|
314 | # Check SID usable in CACHE |
---|
315 | SID_CACHE->{$self->get_sid_index} = $self |
---|
316 | if $self->get_sid_index ; |
---|
317 | |
---|
318 | # Set status is cached |
---|
319 | $self->cache_timer ; |
---|
320 | $self->is_cached(1); |
---|
321 | |
---|
322 | &TIMESTAT('STATUS-OBJECT-CACHED'); |
---|
323 | 1 ; |
---|
324 | } |
---|
325 | |
---|
326 | sub cache_timer { |
---|
327 | # Update the cache timer |
---|
328 | $_[0]->{TIMER} = &ms() ; |
---|
329 | } |
---|
330 | |
---|
331 | sub timer { |
---|
332 | return $_[0]->{TIMER} || 0 ; |
---|
333 | } |
---|
334 | |
---|
335 | sub is_cached { |
---|
336 | my $self = shift ; |
---|
337 | return @_ ? ((defined($_[0]) and $_[0]) ? |
---|
338 | $self->set_dirty_bit(10) : $self->unset_dirty_bit(10)) |
---|
339 | : $self->dirty_bit(10) ; |
---|
340 | } |
---|
341 | |
---|
342 | ############## Dirty bits ############################ Dirty bits ############## |
---|
343 | # 1 -> Dirty cache: Cached status must be written to tied status hash |
---|
344 | # 2 -> Cache synched with DB, need to written new version in tied status hash |
---|
345 | # 3 -> Status is new or is not done in DB -> can't be removed from tied hash |
---|
346 | # 4 -> Cache and hash are synched: versioning can be updated in DB |
---|
347 | ############## Dirty bits ############################ Dirty bits ############## |
---|
348 | sub dirty_bit { |
---|
349 | my $self = shift ; |
---|
350 | my $set = shift || 1 ; |
---|
351 | &StatusDebug("SET not defined") unless (defined($set)); |
---|
352 | if (@_) { |
---|
353 | $self->{DIRTY} = 0 unless (exists($self->{DIRTY})); |
---|
354 | vec($self->{DIRTY},$set,1) = (defined($_[0]) and $_[0])? 1 : 0 ; |
---|
355 | } |
---|
356 | return exists($self->{DIRTY}) ? vec($self->{DIRTY},$set,1) : 0 ; |
---|
357 | } |
---|
358 | |
---|
359 | sub set_dirty_bit { |
---|
360 | # Set a bit with birty bit API |
---|
361 | my $self = shift ; |
---|
362 | my $bit = shift || 1 ; |
---|
363 | return $self->dirty_bit( $bit, 1 ); |
---|
364 | } |
---|
365 | |
---|
366 | sub unset_dirty_bit { |
---|
367 | # Unset a bit with birty bit API |
---|
368 | my $self = shift ; |
---|
369 | my $bit = shift || 1 ; |
---|
370 | return $self->dirty_bit( $bit, 0 ); |
---|
371 | } |
---|
372 | |
---|
373 | sub get_cached_age { |
---|
374 | return $_[0]->timer ? &ms() - $_[0]->timer : 0 |
---|
375 | } |
---|
376 | |
---|
377 | sub check_cached_aged { |
---|
378 | my $self = shift ; |
---|
379 | # Check if our cache is too aged |
---|
380 | if ($STATUS_CACHE_MAXAGE and defined($self)) { |
---|
381 | my $age = $self->get_cached_age ; |
---|
382 | if ( $age > $STATUS_CACHE_MAXAGE ) { |
---|
383 | &MAXSTAT('STATUS-OBJECT-CACHE-AGE',$age); |
---|
384 | &UPSTAT('CACHED-STATUS-OBJECT-CLEANED'); |
---|
385 | $self->remove_from_cache ; |
---|
386 | $self = undef ; |
---|
387 | |
---|
388 | } else { |
---|
389 | # Set status is cached |
---|
390 | $self->is_cached(1); |
---|
391 | } |
---|
392 | } |
---|
393 | return $self ; |
---|
394 | } |
---|
395 | |
---|
396 | sub real_age { |
---|
397 | return defined($_[0]->{BORN}) ? &ms() - $_[0]->{BORN} : 0 ; |
---|
398 | } |
---|
399 | |
---|
400 | sub StatusDebug { |
---|
401 | return 1 unless $ADVANCED_DEBUGGING ; |
---|
402 | my $add = "" ; |
---|
403 | if ($0 !~ /^TEST/) { |
---|
404 | if (defined($MESG{$_[0]}) |
---|
405 | and my ( $repeat, $timeout ) = @{$MESG{$_[0]}}) { |
---|
406 | $MESG{$_[0]}->[0] ++ ; |
---|
407 | return 1 unless ( &ms() >= $timeout ); |
---|
408 | $add = " ($repeat times)" unless ($repeat==1); |
---|
409 | |
---|
410 | } else { |
---|
411 | $MESG{$_[0]} = [ 1 ] ; |
---|
412 | } |
---|
413 | } |
---|
414 | $MESG{$_[0]}->[1] = &ms(60) ; # Keep time out in one minute |
---|
415 | my ($package, $filename, $line) = caller ; |
---|
416 | &Debug( map { "at L.$line: " .$_ .$add } @_ ); |
---|
417 | } |
---|
418 | |
---|
419 | sub get_lockid { |
---|
420 | return defined($_[0]->{LOCKID}) ? $_[0]->{LOCKID} : $LOCKID ; |
---|
421 | } |
---|
422 | |
---|
423 | sub _format_info_to_keep { |
---|
424 | my $this = shift ; |
---|
425 | my $key = shift ; |
---|
426 | my $value = shift ; |
---|
427 | |
---|
428 | # Only handle the special case 'ABTERM' |
---|
429 | return $value |
---|
430 | unless ($key =~ /^ABTERM|ERRORS$/); |
---|
431 | |
---|
432 | # Manage ABTERM case as growing array stripping ABTERM string |
---|
433 | my $ref = ref($this->{$key}) =~ /^ARRAY/i ? $this->{$key} : [] ; |
---|
434 | $value =~ s/^ABTERM[:]*\s*// ; |
---|
435 | push @{$ref} , $value ; |
---|
436 | |
---|
437 | return $ref ; |
---|
438 | } |
---|
439 | |
---|
440 | sub infos { |
---|
441 | my $self = shift ; |
---|
442 | my $Infos = shift || {} ; |
---|
443 | |
---|
444 | # Check $Infos is hash ref |
---|
445 | return &Debug("Can't handle such information format ($Infos)") && 0 |
---|
446 | unless ( ref($Infos) =~ /^HASH/i ); |
---|
447 | |
---|
448 | my $tmpref = $self ; |
---|
449 | |
---|
450 | # When called with a JID, we will have specific informations |
---|
451 | if (defined($Infos->{JID})) { |
---|
452 | # Update what we are for next informations |
---|
453 | $self->{$Infos->{JID}} = {} unless (defined($self->{$Infos->{JID}})); |
---|
454 | $tmpref = $self->{$Infos->{JID}} ; |
---|
455 | $self->is_job($Infos->{JID}); |
---|
456 | delete $Infos->{JID} ; |
---|
457 | } |
---|
458 | |
---|
459 | while ( my ( $key, $info ) = each(%{$Infos}) ) { |
---|
460 | |
---|
461 | $info = "" unless (defined($info)); |
---|
462 | |
---|
463 | # Strip not cesure chars and strip strings |
---|
464 | $info =~ s|[^ .0-9A-Za-z%_/-]||g ; |
---|
465 | $info =~ s/^\s+// ; |
---|
466 | $info =~ s/\s+$// ; |
---|
467 | |
---|
468 | $tmpref->{$key} = _format_info_to_keep($tmpref, $key, $info) ; |
---|
469 | } |
---|
470 | |
---|
471 | # Also auto update |
---|
472 | $self->_auto_update ; |
---|
473 | |
---|
474 | 1 ; |
---|
475 | } |
---|
476 | |
---|
477 | sub _auto_update { |
---|
478 | my $self = shift ; |
---|
479 | |
---|
480 | # Check to update STATUS to ABTERM if ABTERM defined and STATUS is empty |
---|
481 | $self->{STATUS} = 'ABTERM' |
---|
482 | if (defined($self->{ABTERM}) and $self->{ABTERM} |
---|
483 | # Control we are not trying to validate the job |
---|
484 | and ( ref($self->{ABTERM}) !~ /^ARRAY/i |
---|
485 | or $self->{ABTERM}->[$#{$self->{ABTERM}}] !~ /^validated/i ) |
---|
486 | and ( ! defined($self->{STATUS}) or ! $self->is_abterm )); |
---|
487 | |
---|
488 | # Check job count |
---|
489 | if (my ( $number ) = $self->{JOB} =~ /-(\d+)$/) { |
---|
490 | # Update jobs index list with jid hash ref |
---|
491 | $self->{JOBS}->[$number] = $self->is_job ; |
---|
492 | |
---|
493 | $self->{NBJOBS} = $number |
---|
494 | if (!defined($self->{NBJOBS}) or $self->{NBJOBS} < $number ); |
---|
495 | } |
---|
496 | } |
---|
497 | |
---|
498 | my $ko_status = qr/^ko|abterm$/i ; |
---|
499 | sub is_abterm { |
---|
500 | return $_[0]->{STATUS} =~ $ko_status ; |
---|
501 | } |
---|
502 | |
---|
503 | my $done_status = qr/^DONE$/i ; |
---|
504 | sub is_done { |
---|
505 | return $_[0]->{STATUS} =~ $done_status ; |
---|
506 | } |
---|
507 | |
---|
508 | sub is_filtered { |
---|
509 | # Need to return 1 when not matching filters, filters are references |
---|
510 | my $self = shift ; |
---|
511 | my $job_filter = shift ; |
---|
512 | my $day_filter = shift ; |
---|
513 | my $status_filter = shift ; |
---|
514 | |
---|
515 | return &Error("Unsupported filtering mode") |
---|
516 | unless ( grep { |
---|
517 | ref($_) =~ /^SCALAR/ } $day_filter, $job_filter, $status_filter |
---|
518 | == 3 ) ; |
---|
519 | |
---|
520 | # Filter on the day is done only |
---|
521 | return 1 |
---|
522 | if ($$day_filter and ! defined($self->{'ABTERM'}) |
---|
523 | and $self->is_done and $self->{'DAY'} !~ /^$$day_filter$/); |
---|
524 | |
---|
525 | # Filter on status |
---|
526 | if ( $$status_filter ) { |
---|
527 | my ( $not , $filter ) = $$status_filter =~ /^(!?)(.*)$/ ; |
---|
528 | if ($filter = qr/^$filter$/i) { |
---|
529 | return 1 |
---|
530 | if (($not and $self->{'STATUS'} =~ $filter) or |
---|
531 | (! $not and $self->{'STATUS'} !~ $filter)); |
---|
532 | } |
---|
533 | } |
---|
534 | |
---|
535 | return 0 unless ($$job_filter); |
---|
536 | |
---|
537 | # We are filtering on a regex |
---|
538 | my $filter = ref($$job_filter) =~ /^regex/i ? $$job_filter : qr/$$job_filter/i ; |
---|
539 | return ( $self->{'AFP'} !~ $filter and $self->{'JOBID'} !~ $filter ); |
---|
540 | } |
---|
541 | |
---|
542 | sub is_finished { |
---|
543 | return ( $_[0]->{STEP} == 12 and $_[0]->step_status(12) eq 'o' ) ? 1 : 0 ; |
---|
544 | } |
---|
545 | |
---|
546 | sub is_job { |
---|
547 | my $self = shift ; |
---|
548 | $self->{JOB} = shift if (@_ and defined($_[0])); |
---|
549 | return $self->{JOB} ; |
---|
550 | } |
---|
551 | |
---|
552 | sub is_tied_timer { |
---|
553 | my $self = shift ; |
---|
554 | $self->{TIED_TIMER} = shift if @_ ; |
---|
555 | return $self->{TIED_TIMER} || 0 ; |
---|
556 | } |
---|
557 | |
---|
558 | sub is_tied { |
---|
559 | # Have to update us against tied version |
---|
560 | my $self = shift ; |
---|
561 | |
---|
562 | my $sidkey = $_[0] || $self->get_sid_key(@_) ; |
---|
563 | return 0 unless (exists($TIEHASH->{$sidkey})); |
---|
564 | |
---|
565 | #&StatusDebug("Controling $sidkey from tied hash"); |
---|
566 | while ($TIEHASH->{$sidkey} =~ /^\d+$/) { |
---|
567 | &Error("$sidkey sidkey is not status but reference to " . |
---|
568 | $TIEHASH->{$sidkey}); |
---|
569 | |
---|
570 | my $rev_key = $self->get_sid_version_key($sidkey) ; |
---|
571 | if (exists($TIEHASH->{$rev_key})) { |
---|
572 | &Info("$rev_key revision key exists for $sidkey, removing it..."); |
---|
573 | delete $TIEHASH->{$rev_key} ; |
---|
574 | } |
---|
575 | |
---|
576 | my $newkey = $self->get_sid_key($TIEHASH->{$sidkey}) ; |
---|
577 | unless (exists($TIEHASH->{$newkey})) { |
---|
578 | delete $TIEHASH->{$sidkey} ; |
---|
579 | return &Error("Bad reference to $sidkey"); |
---|
580 | } |
---|
581 | |
---|
582 | $sidkey = $newkey ; |
---|
583 | } |
---|
584 | |
---|
585 | &TIMESTAT('IS-TIED-API'); |
---|
586 | |
---|
587 | # Work-around to a possible concurrencing case when key is updated in |
---|
588 | # another process after a split job event, fix a a2p-status service crash |
---|
589 | # TODO reproduce the case to found a better resolution |
---|
590 | my $newself = $TIEHASH->{$sidkey} ; |
---|
591 | { |
---|
592 | my $tries = 10 ; |
---|
593 | while ( $newself !~ /^\x04/ and $tries -- ) { |
---|
594 | usleep $USLEEP ; |
---|
595 | $newself = $TIEHASH->{$sidkey} ; |
---|
596 | } |
---|
597 | $SIG{'__DIE__'} = sub { undef $newself ; } ; |
---|
598 | $newself = &thaw($newself) if ( $newself =~ /^\x04/ ); |
---|
599 | } |
---|
600 | |
---|
601 | if (ref($newself) =~ /^A2P::Status/) { |
---|
602 | #&StatusDebug("Retrieved $sidkey from tied hash"); |
---|
603 | |
---|
604 | # Control known SID |
---|
605 | $self->set_sid_index( $self->db_sid ) |
---|
606 | unless ( $self->get_sid_index eq $self->db_sid ); |
---|
607 | |
---|
608 | } else { |
---|
609 | &StatusDebug("Can't retrieved $sidkey as A2P::Status from tied hash"); |
---|
610 | $newself = 0 ; |
---|
611 | } |
---|
612 | |
---|
613 | &TIMESTAT('IS-TIED-API'); |
---|
614 | |
---|
615 | return $newself ; |
---|
616 | } |
---|
617 | |
---|
618 | sub remove_from_tied_hash { |
---|
619 | # Still return if we don't have write access to tied file |
---|
620 | return unless (_is_tie_writer); |
---|
621 | |
---|
622 | my $self = shift ; |
---|
623 | my $sid_key = $self->get_sid_key ; |
---|
624 | |
---|
625 | # Remove from tied hash if really in tied hash |
---|
626 | return unless (exists($TIEHASH->{$sid_key})); |
---|
627 | |
---|
628 | &TIMESTAT('REMOVE-FROM-TIED'); |
---|
629 | |
---|
630 | &StatusDebug("Removing $sid_key from tied hash"); |
---|
631 | delete $TIEHASH->{$sid_key} ; |
---|
632 | delete $TIEHASH->{$self->get_sid_version_key($sid_key)} ; |
---|
633 | |
---|
634 | # Remove DB hash entry |
---|
635 | $self->_DB_remove ; |
---|
636 | |
---|
637 | # Remove any other reference to us, maybe chained references |
---|
638 | my %remove_it = ( $sid_key => 1 ); |
---|
639 | my %not_ref_to = () ; |
---|
640 | |
---|
641 | while ( my ( $key, $value ) = each(%{$TIEHASH}) ) { |
---|
642 | # Skip well known not reference keys |
---|
643 | next if ( $key =~ /_rev$/ ); |
---|
644 | my $next = $self->get_sid_key($value) ; |
---|
645 | if ( $key =~ /^_SID_/ or $value =~ /\x04/ |
---|
646 | or exists($not_ref_to{$next}) or exists($not_ref_to{$key}) ) { |
---|
647 | $not_ref_to{$key} = 1 ; |
---|
648 | next ; |
---|
649 | } |
---|
650 | |
---|
651 | # Remove this key if it points to a well known reference to sid_key |
---|
652 | if ( exists($remove_it{$next}) ) { |
---|
653 | $remove_it{$key} = 1 ; |
---|
654 | |
---|
655 | } else { |
---|
656 | # Check chained reference |
---|
657 | my %list = ( $key => 1 ) ; |
---|
658 | |
---|
659 | while ( $value ) { |
---|
660 | $value = $TIEHASH->{$next} || '' ; |
---|
661 | if ( exists($remove_it{$next}) ) { |
---|
662 | map { $remove_it{$_} = 1 } keys(%list) ; |
---|
663 | last ; |
---|
664 | |
---|
665 | } elsif ( $next =~ /^_SID_/ or $value =~ /\x04/ |
---|
666 | or exists($not_ref_to{$value}) ) { |
---|
667 | map { $not_ref_to{$_} = 1 } keys(%list) ; |
---|
668 | last ; |
---|
669 | } |
---|
670 | |
---|
671 | # Avoid looping infinitely on cross reference |
---|
672 | last if (exists($list{$next})); |
---|
673 | $list{$next} = 1 ; |
---|
674 | $next = $self->get_sid_key($value) ; |
---|
675 | } |
---|
676 | } |
---|
677 | } |
---|
678 | |
---|
679 | # Now delete the found references, removing referenced key |
---|
680 | delete $remove_it{$sid_key} ; |
---|
681 | map { delete $TIEHASH->{$_} } keys(%remove_it) ; |
---|
682 | |
---|
683 | &TIMESTAT('REMOVE-FROM-TIED'); |
---|
684 | } |
---|
685 | |
---|
686 | sub remove_from_db { |
---|
687 | my $self = shift ; |
---|
688 | # Delete the row and eventually and eventually optimize the table |
---|
689 | &job_status_delete($self->get_sid_index) if ($self->get_sid_index); |
---|
690 | } |
---|
691 | |
---|
692 | sub remove_from_cache { |
---|
693 | my $self = shift ; |
---|
694 | |
---|
695 | # Delete any used key pointing to ourself |
---|
696 | map { |
---|
697 | delete $CACHE->{$_} |
---|
698 | |
---|
699 | } grep { $CACHE->{$_} == $self } keys(%{$CACHE}) ; |
---|
700 | |
---|
701 | # Check any SID pointing to ourself |
---|
702 | map { |
---|
703 | delete SID_CACHE->{$_} |
---|
704 | |
---|
705 | } grep { SID_CACHE->{$_} == $self } keys(%{&SID_CACHE}) ; |
---|
706 | |
---|
707 | # Here cache should not have any reference to us, will die here |
---|
708 | $self->is_cached(0); |
---|
709 | } |
---|
710 | |
---|
711 | sub clone { |
---|
712 | return &thaw(&freeze($_[0])) ; |
---|
713 | } |
---|
714 | |
---|
715 | sub checked_in_db_timer { |
---|
716 | my $self = shift ; |
---|
717 | my @v = @_ ? ( $_[0] ? &ms() : 0 ) : () ; |
---|
718 | return @v ? $self->_DB_this( 'CHK', 0, @v ) : $self->_DB_this( 'CHK', 0 ); |
---|
719 | } |
---|
720 | |
---|
721 | sub check_update_in_db { |
---|
722 | my $self = shift ; |
---|
723 | my $sid = $self->get_sid_index || $self->db_sid ; |
---|
724 | |
---|
725 | unless ($sid) { |
---|
726 | # Don't check if no SID available |
---|
727 | &UPSTAT('STATUS-BAD-CHECK-UPDATE'); |
---|
728 | return 0 ; |
---|
729 | } |
---|
730 | |
---|
731 | # Don't recheck in DB too quickly, one time by minute is sufficient |
---|
732 | return 0 if ($self->checked_in_db_timer > &ms(-60)); |
---|
733 | |
---|
734 | # Update checked in db timer to current time |
---|
735 | $self->checked_in_db_timer(1); |
---|
736 | |
---|
737 | my $updated = 0 ; |
---|
738 | my @row = &is_job_status_updated($self->get_sid_index,$self->get_revision); |
---|
739 | if (@row) { |
---|
740 | # Update ourself |
---|
741 | my @keys =qw( LOCKID JOBID REV TIMER STEP |
---|
742 | STATE BORN DAY AFP STATUS INFOS ); |
---|
743 | foreach my $key (@keys) { |
---|
744 | my $value = shift @row ; |
---|
745 | unless (defined($value)) { |
---|
746 | &StatusDebug("Bad update on $key value"); |
---|
747 | last ; |
---|
748 | } |
---|
749 | if ($key eq 'STATE') { |
---|
750 | $self->{$key} = [ split(//,$value) ] ; |
---|
751 | |
---|
752 | } else { |
---|
753 | $self->{$key} = $value ; |
---|
754 | } |
---|
755 | $updated ++ ; |
---|
756 | } |
---|
757 | &StatusDebug("Updated $updated values from DB for job ".$self->{JOBID}); |
---|
758 | $self->set_dirty_bit ; |
---|
759 | } |
---|
760 | return $updated ; |
---|
761 | } |
---|
762 | |
---|
763 | sub _DB_name { |
---|
764 | return $_[0]->{JOBID} ; |
---|
765 | } |
---|
766 | |
---|
767 | sub _DB_this { |
---|
768 | my $self = shift ; |
---|
769 | my $key = shift or return 0 ; |
---|
770 | my $def = shift || 0 ; |
---|
771 | my $job = $self->_DB_name ; |
---|
772 | $DB->{$job} = {} unless (exists($DB->{$job})); |
---|
773 | $DB->{$job}->{$key} = shift if ( @_ and defined($_[0]) ); |
---|
774 | return exists($DB->{$job}->{$key}) ? $DB->{$job}->{$key} : $def ; |
---|
775 | } |
---|
776 | |
---|
777 | sub _DB_remove { |
---|
778 | # Free memory to be called when no more needed. Should be called when the |
---|
779 | # comparaison object is no more available in tied hash |
---|
780 | my $self = shift ; |
---|
781 | &UPSTAT('STATUS-DB-REMOVE'); |
---|
782 | &UPSTAT('STATUS-DB-REMOVE-AGE',$self->real_age); |
---|
783 | delete $DB->{$self->_DB_name} if (exists($DB->{$self->_DB_name})); |
---|
784 | } |
---|
785 | |
---|
786 | sub db_revision { |
---|
787 | my $self = shift ; |
---|
788 | return @_ ? $self->_DB_this( 'REV', 0, @_ ) : $self->_DB_this( 'REV', 0 ); |
---|
789 | } |
---|
790 | |
---|
791 | sub db_sid { |
---|
792 | my $self = shift ; |
---|
793 | return @_ ? $self->_DB_this( 'SID', 0, @_ ) : $self->_DB_this( 'SID', 0 ); |
---|
794 | } |
---|
795 | |
---|
796 | sub db_checked { |
---|
797 | my $self = shift ; |
---|
798 | $self->_DB_this( 'SYNC_TIMER', 0, &ms() ); |
---|
799 | return $self->_DB_this( 'CHECKED', 0, $self->_DB_this( 'CHECKED', 0 )+1 ); |
---|
800 | } |
---|
801 | |
---|
802 | sub checking_too_quickly { |
---|
803 | return ( &ms() - $_[0]->_DB_this( 'SYNC_TIMER', 0 ) > 500 ) ? 0 : 1 ; |
---|
804 | } |
---|
805 | |
---|
806 | sub is_newer_than_db { |
---|
807 | my $self = shift ; |
---|
808 | return ( $self->db_revision < $self->get_revision ) ? 1 : 0 ; |
---|
809 | } |
---|
810 | |
---|
811 | sub sync_with_db { |
---|
812 | my $self = shift ; |
---|
813 | my $job = $self->is_job ; |
---|
814 | |
---|
815 | $! = 0 ; |
---|
816 | |
---|
817 | # Get the current SID for that status |
---|
818 | my $sid = $self->get_sid_index || $self->db_sid ; |
---|
819 | |
---|
820 | # We update when we know DB rev is lower than current from cache |
---|
821 | if ( $self->is_newer_than_db ) { |
---|
822 | # Prepare row for update |
---|
823 | my @row = ( $sid ) ; |
---|
824 | push @row, map { defined($self->{$_}) ? $self->{$_} : "NULL" } qw{ |
---|
825 | LOCKID JOBID REV TIMER STEP |
---|
826 | STATE BORN DAY AFP STATUS NBJOBS |
---|
827 | }; |
---|
828 | |
---|
829 | # Add DestId list |
---|
830 | my %destids = () ; |
---|
831 | my @jobs = defined($self->{JOBS}) ? |
---|
832 | grep { defined($_) } @{$self->{JOBS}} : () ; |
---|
833 | map { $destids{uc($self->{$_}->{DESTID})} = 1 } |
---|
834 | grep { defined($self->{$_}->{DESTID}) } @jobs ; |
---|
835 | if (exists($destids{NULL})) { # Protect NULL DestID if defined |
---|
836 | delete $destids{NULL} ; |
---|
837 | $destids{'(NULL)'} = 1 ; |
---|
838 | } |
---|
839 | push @row, join(" ",keys(%destids)) || "none" ; |
---|
840 | |
---|
841 | push @row, $self->{INFOS} || "" ; |
---|
842 | |
---|
843 | # Check if update is done and we can continue the process |
---|
844 | $sid = &job_status_update(@row) ; |
---|
845 | unless ( $sid and ($sid == $self->db_sid or $self->db_sid($sid))) { |
---|
846 | &Debug("Can't sync $job with @row to db row sid ".$sid); |
---|
847 | return 0 ; |
---|
848 | } |
---|
849 | |
---|
850 | # Update revision |
---|
851 | $self->db_revision($self->get_revision); |
---|
852 | |
---|
853 | } elsif ( ! $self->dirty_bit(3) ) { |
---|
854 | # Check if ABTERM status was updated by another service, this API do it |
---|
855 | # at last one time by minute. We don't need to check GOOD status as they |
---|
856 | # can't be updated to better status |
---|
857 | &UPSTAT('STATUS-UPDATED-FROM-DB') |
---|
858 | if ( $self->is_abterm and $self->check_update_in_db ); |
---|
859 | } |
---|
860 | |
---|
861 | # Update our cache if gotten SID is different, check it as |
---|
862 | # string as SIDs from standard thread are string by default (afp jobname) |
---|
863 | if ( $self->get_sid_index ne $self->db_sid ) { |
---|
864 | $self->set_sid_index( $self->db_sid ); |
---|
865 | } |
---|
866 | |
---|
867 | # Keep statistics on control |
---|
868 | &MAXSTAT('STATUS-RESYNCH-CHECKED',$self->db_checked); |
---|
869 | |
---|
870 | # TODO Find why some time db_revision is greater than get_revision, maybe |
---|
871 | # because a status update is done by a process on older status in its cache |
---|
872 | unless ($self->db_revision and $self->db_revision >= $self->get_revision) { |
---|
873 | &Debug("$job DB revision is " . $self->db_revision . " but ours is " . |
---|
874 | $self->get_revision); |
---|
875 | return 0 ; |
---|
876 | } |
---|
877 | |
---|
878 | return 1 ; |
---|
879 | } |
---|
880 | |
---|
881 | sub get_next_from_db { |
---|
882 | my $self = shift ; |
---|
883 | |
---|
884 | # Get the next row as a hash with column names as keys |
---|
885 | my $row = &get_next_jobstatus( $self->get_sid_index, @_ ) ; |
---|
886 | |
---|
887 | return 0 unless (ref($row) =~ /^HASH/); |
---|
888 | |
---|
889 | # Invalidate ourself with empty JobID |
---|
890 | $self->{JOBID} = '' ; |
---|
891 | $self->is_job('INVALID JOB ROW'); |
---|
892 | |
---|
893 | # Update ourself to job in DB values |
---|
894 | foreach my $key (keys(%{$row})) { |
---|
895 | if ($key eq 'STATE') { |
---|
896 | $self->{STATE} = [ split(//,$row->{STATE}) ] ; |
---|
897 | } else { |
---|
898 | $self->{$key} = $row->{$key} ; |
---|
899 | } |
---|
900 | } |
---|
901 | |
---|
902 | # Keep who we are now as valid job |
---|
903 | $self->is_job($self->{JOBID}) if ($self->{JOBID}); |
---|
904 | |
---|
905 | 1 ; |
---|
906 | } |
---|
907 | |
---|
908 | sub set_revision { |
---|
909 | return ++ $_[0]->{REV} ; |
---|
910 | } |
---|
911 | |
---|
912 | sub get_revision { |
---|
913 | return $_[0]->{REV} ; |
---|
914 | } |
---|
915 | |
---|
916 | sub save_tied_versioning { |
---|
917 | # We assume we can write to tied hash |
---|
918 | my $self = shift ; |
---|
919 | my $version = [ $self->get_revision, $self->get_lockid, $self->timer ] ; |
---|
920 | #&StatusDebug("Saving ".$self->is_job." rev. ".$self->get_revision. |
---|
921 | # " versioning at key ".$self->get_sid_version_key(@_)); |
---|
922 | return $TIEHASH->{$self->get_sid_version_key(@_)} = &freeze($version); |
---|
923 | } |
---|
924 | |
---|
925 | sub is_tied_versioning { |
---|
926 | my $self = shift ; |
---|
927 | my $key = $self->get_sid_version_key(@_) ; |
---|
928 | unless (defined($TIEHASH->{$key})) { |
---|
929 | &StatusDebug("Versioning key $key is lost"); |
---|
930 | return ( 0, $LOCKID, 0 ); |
---|
931 | } |
---|
932 | my @version = @{&thaw($TIEHASH->{$key})}; |
---|
933 | return @version ; |
---|
934 | } |
---|
935 | |
---|
936 | sub is_older_than_tied { |
---|
937 | # When comparing with tied version, we should check first the timer when |
---|
938 | # checking on the same LOCKID assuming this is the same service in the |
---|
939 | # same place |
---|
940 | my $self = shift ; |
---|
941 | my ( $rev, $lockid, $timer ) = $self->is_tied_versioning(@_) ; |
---|
942 | |
---|
943 | # Set ourself as dirty cached status if we are newer than tied version |
---|
944 | $self->set_dirty_bit if ($self->get_revision > $rev); |
---|
945 | |
---|
946 | #&StatusDebug("Comparing to @_ tied rev $rev, lockid $lockid, timer $timer"); |
---|
947 | return (( $LOCKID =~ /^$lockid$/ and $self->timer < $timer ) or |
---|
948 | $self->get_revision < $rev ) ? $rev : 0 ; |
---|
949 | } |
---|
950 | |
---|
951 | sub status { |
---|
952 | my $self = shift ; |
---|
953 | return $self->{STATUS} = defined($self->{STATUS}) ? uc($self->{STATUS}) : "" ; |
---|
954 | } |
---|
955 | |
---|
956 | sub step_status { |
---|
957 | my $self = shift ; |
---|
958 | |
---|
959 | # Remove any undefined value, arise when starting a job |
---|
960 | while (@_ and !defined($_[0])) { shift } |
---|
961 | |
---|
962 | my $Step = shift || 0 ; |
---|
963 | |
---|
964 | # Check step value to avoid updating job status on unused step |
---|
965 | return 0 if ($Step < 0 or $Step > 12 ); |
---|
966 | |
---|
967 | if (@_) { |
---|
968 | # Set step and later keep us in cache |
---|
969 | my $State = shift || '.' ; |
---|
970 | |
---|
971 | # Check we can update status |
---|
972 | if ( $Step < 3 and $State =~ /^[._]$/ ) { |
---|
973 | my $prev = $self->{STATE}->[$Step-1] || '0' ; |
---|
974 | # Step starting, previous step must be 'o', '0', '_', '-' or 'A' |
---|
975 | return 0 unless ( $prev =~ /^[0Ao_-]$/ ); |
---|
976 | |
---|
977 | } elsif ( $Step == 1 and $State eq 'o' ) { |
---|
978 | # First call initializing a basic job status entry. This is |
---|
979 | # done the first time in SpoolManager when processing AFP file |
---|
980 | my $last = $self->{STATE}->[1] ; # Check job has still been started |
---|
981 | my $restarted = (defined($last) and $last ne '_') ? |
---|
982 | (exists($self->{FILE}) ? $self->{FILE} : $self->{AFP}) : '' ; |
---|
983 | |
---|
984 | &Debug("Starting job " . $self->is_job . |
---|
985 | ($restarted?"... ($restarted)":"")); |
---|
986 | |
---|
987 | # Initializes our birth and keep us in cache |
---|
988 | $self->_set_defaults ; |
---|
989 | $self->_born ; |
---|
990 | |
---|
991 | # Check to remove old job status from previous start |
---|
992 | if ($restarted) { |
---|
993 | $self->{RESTARTED} = time ; |
---|
994 | $self->{RESTART} = exists($self->{RESTART}) ? |
---|
995 | ++ $self->{RESTART} : 1 ; |
---|
996 | |
---|
997 | # Set first step to number indicates a restart (with 0 -> >10) |
---|
998 | $self->{STATE}->[0] = $self->{RESTART} > 9 ? |
---|
999 | 0 : $self->{RESTART} ; |
---|
1000 | |
---|
1001 | &Info("Seems to restart $restarted job".($self->{RESTART}>1? |
---|
1002 | " (restart #".$self->{RESTART}.")":"")); |
---|
1003 | } |
---|
1004 | |
---|
1005 | # Set this status is new to being handled quickly |
---|
1006 | $self->set_is_new ; |
---|
1007 | |
---|
1008 | } elsif ( $Step == 1 and $State eq 'V' ) { |
---|
1009 | # Specific to validation: force as new |
---|
1010 | $self->set_is_new ; |
---|
1011 | $State = 'o' ; |
---|
1012 | } |
---|
1013 | |
---|
1014 | # Don't update STEP if still at higher step (protection) |
---|
1015 | $self->{STEP} = $Step unless ( $self->{STEP} > $Step ); |
---|
1016 | |
---|
1017 | # Update STATE checking if we can really update it |
---|
1018 | $self->{STATE}->[$Step] = $State |
---|
1019 | unless ( $self->{STATE}->[$Step] eq 'o' |
---|
1020 | or ( $self->{STATE}->[$Step] eq 'A' and $State ne 'o' ) ); |
---|
1021 | |
---|
1022 | # Now set cache is dirty |
---|
1023 | $self->set_dirty_bit ; |
---|
1024 | } |
---|
1025 | |
---|
1026 | # Still return the current step |
---|
1027 | return $self->{STATE}->[$Step] eq '0' ? '_' : $self->{STATE}->[$Step] ; |
---|
1028 | } |
---|
1029 | |
---|
1030 | sub set_is_new { |
---|
1031 | my $self = shift ; |
---|
1032 | |
---|
1033 | # 1. Set the bit 3 to guaranty the status is not removed from tied hash |
---|
1034 | # Before it is in DB |
---|
1035 | $self->set_dirty_bit(3); |
---|
1036 | |
---|
1037 | # 2. Use shared list of new status to inform a2p-status to handle this one |
---|
1038 | # This is done in SpoolManager thread |
---|
1039 | my $shared_list = &SharedList( $self->get_lockid ); |
---|
1040 | push @{$shared_list}, $self->get_sid_key ; |
---|
1041 | &FreeSharedList( $self->get_lockid ); |
---|
1042 | |
---|
1043 | # 3. Remove any stored Error or ABTERM |
---|
1044 | delete $self->{ABTERM} ; |
---|
1045 | delete $self->{ERRORS} ; |
---|
1046 | |
---|
1047 | # 4. Remove any child error |
---|
1048 | if (exists($self->{JOBS}) and ref($self->{JOBS}) =~ /^ARRAY/i) { |
---|
1049 | map { |
---|
1050 | delete $self->{$_} ; |
---|
1051 | |
---|
1052 | } grep { |
---|
1053 | defined($_) and $_ and exists($self->{$_}) |
---|
1054 | } @{$self->{JOBS}} ; |
---|
1055 | |
---|
1056 | delete $self->{JOBS} ; |
---|
1057 | } |
---|
1058 | } |
---|
1059 | |
---|
1060 | sub save_tied { |
---|
1061 | my $self = shift ; |
---|
1062 | |
---|
1063 | # Update our revision before trying to save it in tied hash |
---|
1064 | # But disable setting revision if requested for the case of just renaming |
---|
1065 | # status in tied hash |
---|
1066 | $self->set_revision() unless ( @_ and $_[0] =~ /^not a revision$/ ); |
---|
1067 | |
---|
1068 | # Check we are really tied |
---|
1069 | return 0 unless ( _is_tie_writer ); |
---|
1070 | |
---|
1071 | &TIMESTAT('SAVE-TIED'); |
---|
1072 | |
---|
1073 | # Reference is a number when we are knowing the SID index in DB |
---|
1074 | # otherwise it's the first inserted key in tied hash given by get_sid_key |
---|
1075 | my $sid_ref = $self->get_sid_index || $self->get_sid_key ; |
---|
1076 | |
---|
1077 | # Update any important reference |
---|
1078 | my $sidkey_re = qr/^$sid_ref$/ ; |
---|
1079 | foreach my $ref (qw{ JOB AFP JOBID LINKEDAFP }) { |
---|
1080 | # Skip undefined and not set |
---|
1081 | next unless (defined($self->{$ref}) and $self->{$ref}); |
---|
1082 | # Skip the SID key itself |
---|
1083 | next if ( $self->{$ref} =~ $sidkey_re ); |
---|
1084 | # Skip if ref is still set |
---|
1085 | next if ( defined($TIEHASH->{$self->{$ref}}) and |
---|
1086 | $TIEHASH->{$self->{$ref}} =~ $sidkey_re ); |
---|
1087 | # Then set reference |
---|
1088 | $TIEHASH->{$self->{$ref}} = $sid_ref ; |
---|
1089 | #&StatusDebug($self->{$ref}." replaced"); |
---|
1090 | # Delete old versioning |
---|
1091 | if (exists($TIEHASH->{$self->{$ref}._rev_ext})) { |
---|
1092 | delete $TIEHASH->{$self->{$ref}._rev_ext}; |
---|
1093 | #&StatusDebug($self->{$ref}._rev_ext. " deleted"); |
---|
1094 | } |
---|
1095 | } |
---|
1096 | |
---|
1097 | # Reset cached status |
---|
1098 | my $cached = $self->is_cached ; |
---|
1099 | $self->is_cached(0); |
---|
1100 | $self->unset_dirty_bit ; |
---|
1101 | |
---|
1102 | # Update tied timer before freeze |
---|
1103 | $self->is_tied_timer(&ms()); |
---|
1104 | |
---|
1105 | # Prepare tied value as Storable freeze with DB information |
---|
1106 | my $freeze = &freeze($self) ; |
---|
1107 | |
---|
1108 | # Keep statistics on stored length in tied hash |
---|
1109 | &MAXSTAT('MAX-TIED-STATUS-LENGTH',length($freeze)); |
---|
1110 | &UPSTAT('SAVE-TIED'); |
---|
1111 | |
---|
1112 | # Save tied value as Storable freeze |
---|
1113 | my $sidkey = $self->get_sid_key ; |
---|
1114 | $TIEHASH->{$sidkey} = $freeze ; |
---|
1115 | $self->save_tied_versioning($sidkey) ; |
---|
1116 | &Warn("$sidkey SID versioning still lost") |
---|
1117 | unless (defined($TIEHASH->{$sidkey._rev_ext})); |
---|
1118 | #&StatusDebug($self->is_job." saved in tied for key $sidkey rev. " . |
---|
1119 | # $self->get_revision); |
---|
1120 | |
---|
1121 | # Reset cached status and others |
---|
1122 | $self->is_cached($cached); |
---|
1123 | |
---|
1124 | &TIMESTAT('SAVE-TIED'); |
---|
1125 | return $self ; |
---|
1126 | } |
---|
1127 | |
---|
1128 | sub DESTROY { |
---|
1129 | # Remove debug message for minimal object |
---|
1130 | $MUSTQUIT and &StatusDebug("Freeing " . __PACKAGE__ . |
---|
1131 | " object memory " . $_[0]->get_sid_index . ":" . $_[0]->is_job . |
---|
1132 | ( defined($_[0]->{INITIAL}) ? " (" . $_[0]->{INITIAL} . ")" : "" )); |
---|
1133 | } |
---|
1134 | |
---|
1135 | &Debug("Module " . __PACKAGE__ . " v$VERSION loaded"); |
---|
1136 | |
---|
1137 | 1; |
---|