source: A2P/a2p/A2P/JobStatus.pm @ 12

Last change on this file since 12 was 3, checked in by guillaume, 17 years ago
  • AUTHORS: Ajout des différents contributeurs
  • COPYING: Ajout de la licence GPL v3
  • a2p: Préparation des sources pour leur publication sous GPL
  • Property svn:keywords set to Id
File size: 35.1 KB
RevLine 
[3]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# Some job status subfunctions callable from a2p, a2p-status and webmin modules
23#
24
25package A2P::JobStatus ;
26
27use strict;
28use Fcntl;
29use Time::HiRes qw( usleep gettimeofday tv_interval) ;
30use Fcntl qw(:flock F_SETLK F_WRLCK SEEK_SET);
31use File::stat;
32use IO::Socket;
33use GDBM_File;
34use A2P::Globals ;
35use A2P::Syslog ;
36use A2P::Status ;
37use A2P::Tools qw( SharedList FreeSharedList ms );
38
39BEGIN {
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}
51our $VERSION ;
52
53my %TIED_STATUS = () ;    # Tied hash
54my %STATUS      = () ;    # Status object cache
55
56my $LCK ;
57my $CURRENTMODE = 0 ;                     # Access mode to tie: 0 = RO, 1 = R/W
58
59sub _freezed_status_re {
60    qr/^\x04.*A2P::Status/
61}
62
63sub _get_tied_ref {
64    return \%TIED_STATUS ;
65}
66
67sub _not_tied {
68    return tied(%TIED_STATUS) ? 0 : 1 ;
69}
70
71sub _get_cache_ref {
72    return \%STATUS ;
73}
74
75sub cansavetied {
76    $CURRENTMODE = 0 if _not_tied ;
77    return $CURRENTMODE ;
78}
79
80sub 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
93sub 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
100sub newstatus_dbm_base {
101    return $SHMDIR . '/.new-status-' ;
102}
103
104sub dbm_base {
105    return $SHMDIR . '/.jobstatus-' ;
106}
107
108sub 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
131sub 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
146my $search_status = '' ;
147sub 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
174my @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
179sub 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
259sub 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
272sub 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
286sub 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
306sub 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
337my $shrink_timer = {} ; # Timers to reorganize gdbms
338sub _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
384my %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
394my %MESG = () ;
395sub 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
411my $RESYNCH_TIMEOUT = 10 ; # 10 seconds before synchronizing in tied hash
412sub 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
560sub 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
652my @micro_timer = ( 0, 0, 0 ) ;
653sub _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
676sub 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
723sub 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
730sub 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
759my %th_cleaner = ( TIMER => {}, LIST => {} ) ;
760my %lost = () ;
761sub _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
845my $cache_timer     = undef ; # Timer to handle cache check
846my @cache_checklist = () ;
847my @cache_ages      = () ;
848my %age_checklist   = () ;
849my $cache_older     = 0 ;
850sub 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
952my @pending = () ;
953sub 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
1038my $debug_pending_timer ;
1039sub 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
1084END {
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
11081;
Note: See TracBrowser for help on using the repository browser.