source: A2P/a2p/dbm-status-tools.pl @ 15

Last change on this file since 15 was 3, checked in by guillaume, 16 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:executable set to *
  • Property svn:keywords set to Id
File size: 13.6 KB
Line 
1#! /usr/bin/perl
2#
3# Copyright (c) 2004-2007 - Consultas, PKG.fr
4#
5# This file is part of A2P.
6#
7# A2P is free software; you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation; either version 2 of the License, or
10# (at your option) any later version.
11#
12# A2P is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with A2P; if not, write to the Free Software
19# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
20#
21# $Id: dbm-status-tools.pl 3 2007-10-18 16:20:19Z guillaume $
22#
23
24use strict ;
25use Time::HiRes qw( usleep gettimeofday tv_interval) ;
26use Fcntl qw(:flock);
27use GDBM_File ;
28use Storable qw( freeze thaw );
29use Data::Dumper;
30use A2P::Globals ;
31use A2P::Status ;
32use A2P::JobStatus ;
33
34my $jobstatus_base = A2P::JobStatus::dbm_base() ;
35
36$LOCKID = shift @ARGV if @ARGV ;
37
38my $gdbm = ( $LOCKID =~ /^\// and -e $LOCKID )?
39    $LOCKID : $jobstatus_base . $LOCKID ;
40
41# Check file is really a dbm file with 'file' command
42my @control = qx/file $gdbm/ =~ /(dbm).*(database)/i ;
43
44unless ( -e $gdbm and @control == 2 ) {
45    die "File $gdbm not found\n" .
46        "First argument must be the LOCKID for which you to manage status\n" ;
47}
48
49print "Reading $gdbm memory file (".(-s $gdbm).")\n" ;
50my %gdbm ;
51
52sub error {
53    map { print "$_\n" } @_ ;
54    return 0 ;
55}
56
57my $LCK ;
58my ( $uid, $gid );
59sub get_gdbm {
60    return error("File $gdbm doesn't exist")
61        unless -e $gdbm ;
62    my @stat = stat $gdbm ;
63    ( $uid, $gid ) = @stat[4..5] ;
64    open $LCK, '>', $gdbm . '.LCK'
65        or return error("Can't open " . $gdbm . ".LCK locking file: $!");
66    flock $LCK, LOCK_EX
67        or return error("Can't lock on " . $gdbm . ".LCK: $!");
68    tie %gdbm, "GDBM_File", $gdbm, GDBM_WRITER, 0666
69        or return error("Can't tie $gdbm gdbm: $!");
70    1 ;
71}
72
73sub release_gdbm {
74    untie %gdbm ;
75    flock $LCK, LOCK_UN ;
76    close($LCK);
77    chown $uid, $gid, $gdbm ;
78}
79
80sub dump_status {
81    my $this = shift or return "" ;
82    my $dirty = "_".$this->dirty_bit()."_".$this->dirty_bit(3)."____" ;
83    return $this->get_sid_key.": Job ".$this->is_job.
84        " [$this->{STATUS}] step=$this->{STEP}: ".
85        " (".join('',@{$this->{STATE}}).") [Rev$this->{REV}; Sid:$this->{SID} ;"
86        ." dirty bits: $dirty ]" ;
87}
88
89sub confirm {
90    print "Are you sure to do this [y/N] ?" ;
91    my $response = lc(getc);
92    print "\n" ;
93    return $response eq 'y' ? 1 : 0 ;
94}
95
96# Prepare cache and A2P::Status privates
97my $cache = { __GDBM_WRITER__ => 1 };
98my $s = new A2P::Status($cache,\%gdbm,'init');
99$s->remove_from_cache ;
100
101my $quit = 0 ;
102my $index = -1 ;
103my $selected = -1 ;
104my $status ;
105my $name ;
106
107while (!$quit) {
108
109    sleep 1 and next unless (&get_gdbm());
110
111    my @keys = sort(keys(%gdbm)) ;
112    print "===== Service $LOCKID =====\n",
113        "Memory DB keys: ",scalar(@keys)," found\n" ;
114
115    my %keys = map { $_ => 1 } @keys ;
116    my @lost = () ;
117    my %rev  = map {
118        delete $keys{$_} ;
119        /^(.+)_rev$/ ;
120        push @lost , $_ unless (exists($gdbm{$1}));
121        $_ => thaw($gdbm{$_})
122        } grep { /_rev$/ } @keys ;
123
124    print "Lost revisions (".scalar(@lost)."): @lost\n"
125        if ( @lost = sort(@lost) );
126
127    my %ref = map {
128        delete $keys{$_} ;
129        $_ => $gdbm{$_}
130    } grep { ($gdbm{$_} =~ /^\d+$/ and exists($gdbm{'_SID_'.$gdbm{$_}})) or
131                exists($gdbm{$gdbm{$_}}) } keys(%keys) ;
132    my @ref = sort(keys(%ref)) ;
133    print "References found: ", scalar(@ref), "\n" ;
134
135    my %status = map {
136        delete $keys{$_} ;
137        $_ => thaw($gdbm{$_})
138    } grep { $gdbm{$_} =~ /\x04/ } keys(%keys) ;
139    my @status = sort(keys(%status)) ;
140    print "Status    found: ", scalar(@status), "\nRevisions found: ",
141        scalar(keys(%rev)), "\n" ;
142    my $count = 2*@status + @ref ;
143    if ( $count == @keys ) {
144        print "Count is coherent\n" ;
145    } else {
146        print "Bad count found: ".(@keys - $count)." more keys found\n" ;
147    }
148
149    my @unexpected = sort(keys(%keys)) ;
150    print "Not expected keys: @unexpected\n" if @unexpected;
151
152    my $_SID_count = grep { /^_SID_(\d+)$/ } keys(%status) ;
153    my $_SID_rev_count = grep { /^_SID_(\d+)_rev$/ } keys(%rev) ;
154    print "_SID_# count: $_SID_count (+$_SID_rev_count _rev)\n" ;
155
156    &release_gdbm() ;
157
158    if ($selected>=0) {
159        $name = $status[$selected] ;
160        $status = $status{$name} ;
161
162    } elsif ($selected > $#status) {
163        $selected = $#status ;
164        $name = $status[$selected] ;
165        $status = $status{$name} ;
166    }
167
168    unless (defined($status[$selected]) and $name == $status[$selected]) {
169        $selected = -1 ;
170        $name = $status = undef ;
171    }
172
173    # Actions
174    my $a = 0 ;
175    while (!$quit) {
176    print "\n",
177          "q -> Quit             l -> list jobs      m -> list refs         \n",
178          "r -> Refresh          e -> evaluation     j -> select a job      \n",
179          "s -> Shrink dbm       d -> delete job     v -> validate job      \n",
180          "a -> list job refs    x -> dump dbm keys  u -> unselect job      \n",
181          "t -> list twin jobs                                              \n",
182          "f -> Flush lost/unexpected or done                               \n",
183          "[0-9] -> select a job  n/p -> next/previous indexed jobs list    \n"
184          unless ( $a ++ % 5 );
185    if ($index>=0) {
186        print "Current index = $index\n" ;
187        for my $i ( 0..9 ) {
188            if (defined($status[$index+$i])
189            and exists($status{$status[$index+$i]})) {
190                my $this = $status{$status[$index+$i]} ;
191                print "$i - ",dump_status($this),"\n" ;
192            } elsif (defined($status[$index+$i])) {
193                print "$i - Unavailable ",$status[$index+$i],"\n" ;
194            }
195        }
196    }
197    print "DB memory file size: ".(-s $gdbm)."\n" ;
198    print "Selected job '$name': ", dump_status($status), "\n", Dumper($status),
199        "('$name' selected, type 'u' to unselect it)\n"
200        if (defined($name) and defined($status));
201    print "Command ? " ;
202    system "stty", '-icanon', 'eol', "\001";
203    my $key = lc(getc) ;
204    print "\n" ;
205
206    $quit ++ if ($key eq 'q'); # Quit
207    last     if ($key eq 'r'); # Refresh
208
209    if ($key eq 'j') {
210        print "Job: " ;
211        system "stty", 'icanon', 'eol', '^@' ;
212        my $job = <STDIN> ;
213        chomp($job);
214        if (exists($status{$job})) {
215            $status = $status{$job} ;
216        } else {
217            print "$job doesn't exists\n";
218        }
219
220    } elsif ($key eq 'u') {
221        undef $name ;
222        undef $status ;
223        $selected = -1 ;
224
225    } elsif ($key eq 'e') {
226        print "Evaluation: " ;
227        system "stty", 'icanon', 'eol', '^@' ;
228        my $eval = <STDIN> ;
229        chomp($eval);
230        print eval $eval, "\n" ;
231
232    } elsif ($key eq 'v' and defined($name) and defined($status)) {
233        get_gdbm ;
234        if (tied(%gdbm) and confirm) {
235            $status->{STATUS} = 'DONE' ;
236            $status->{STATE}->[12] = 'o' ;
237            $status->{REV} += 100 ;
238            $status->set_dirty_bit(3) ;
239            $status->cache_timer ;
240            $gdbm{$name} = freeze($status) ;
241        }
242        release_gdbm ;
243        last ; # Refresh
244
245    } elsif ($key eq 'd' and defined($name) and defined($status)) {
246        get_gdbm ;
247        $status->remove_from_tied_hash if (tied(%gdbm) and confirm);
248        release_gdbm ;
249        # Select next
250        $selected += $selected < $#status ? 1 : -1 ;
251        $status = $status{$status[$selected]} ;
252        $name = $status[$selected] ;
253        last ; # Refresh
254
255    } elsif ($key eq 'f') {
256        get_gdbm ;
257        if (tied(%gdbm) and confirm) {
258            if (@lost or @unexpected) {
259                map { print '*' ; delete $gdbm{$_} } @lost ;
260                map { print '+' ; delete $gdbm{$_} } @unexpected ;
261
262            } else {
263                my $stop = 0 ;
264                $SIG{INT} = sub { $stop ++ } ;
265                my $i = 0 ;
266                $| = 1 ;
267                foreach $name (keys(%status)) {
268                    $status = $status{$name} ;
269                    last if $stop ;
270                    if ($status->is_abterm
271                    or $status->step_status(12) ne 'o') {
272                        print '-' ;
273                    } else {
274                        delete $gdbm{$name} ;
275                        print '*' ;
276                    }
277                    print ++$i % 100 ? "" : "\n" ;
278                }
279            }
280            print "\n" ;
281        }
282        release_gdbm ;
283        # Remove any selection
284        $selected = -1 ;
285        $status = $name = undef ;
286        last ; # Refresh
287
288    } elsif ($key eq 'x') {
289        get_gdbm ;
290        print "Warning: You must abort quickly dumping if service is running\n",
291            "Gdbm dump:\n";
292        my ( $i, $l, $line ) = ( 0, 0, 0 ) ;
293        my @list = sort(keys(%gdbm)) ;
294        foreach $key (@list) {
295            my $L = length($key)>30 ? 1 : 0 ;
296            if ($l or $L) {
297                print "\n" ;
298                $i = 0 ;
299                $l = $L ;
300                $line ++ ;
301            }
302
303            # Extract comprehensible value
304            my $value = ref($gdbm{$key}) || $gdbm{$key} ;
305            #$value = ref($value)
306            $value = ref(thaw($value)) if ( $value =~ /\x04/ );
307
308            # Keep value as a 30 chars length string
309            my $text = sprintf(": %-26s| ",substr($value,0,26)) ;
310
311            print sprintf("%30s%s",$key,$text);
312
313            # Avoid to output pres a key message when line=0
314            if ( ++$i % 3 ) {
315                next ;
316
317            } else {
318                print "\n" ;
319                $line ++ ;
320            }
321
322            unless ( $line % 20 ) {
323                print "
324                    [ Press any key to continue but [a] to abort the dump ]" ;
325                system "stty", '-icanon', 'eol', "\001";
326                my $press = lc(getc) ;
327                last if ( $press eq 'a' );
328                print "\n" ;
329                ( $i, $l ) = ( 0, 0 ) ;
330            }
331        }
332        print "\n" ;
333        release_gdbm ;
334
335    } elsif ($key eq 't') {
336        print "Twin status:\n";
337        my ( $twin, $same, $checkcount ) = ( 0, 0, 0 );
338        my %done = () ;
339        my @list = sort(keys(%status)) ;
340        my $listtotal = 0 ;
341        $| = 1 ;
342        foreach my $check (@list) {
343            foreach my $cmp
344            (grep { ! exists($done{'__'.$check.'__'.$_.'__'}) } @list) {
345                # Don't compare on the same key
346                next if ( $check eq $cmp );
347
348                # Don't compare if still compared
349                $done{'__'.$cmp.'__'.$check.'__'} = 1 ;
350
351                if ( $status{$check} eq $status{$cmp} ) {
352                    print "$check and $cmp are twins\n" ;
353                    $twin ++ ;
354
355                } elsif ( $status{$check}->{JOBID} eq $status{$cmp}->{JOBID} ) {
356                    print "$check and $cmp are for the same job, but with ",
357                        $status{$check}->{REV}, " vs ", $status{$cmp}->{REV},
358                        " revision, and ", $status{$check}->{STEP}, ":'",
359                        $status{$check}->step_status($status{$check}->{STEP}),
360                        "' vs ", $status{$cmp}->{STEP}, ":'",
361                        $status{$cmp}->step_status($status{$cmp}->{STEP}),
362                        " step/status\n" ;
363                    $same ++ ;
364                }
365
366                $checkcount ++ ;
367            }
368            print sprintf("%.2f%%  \r", ++$listtotal * 100 / @list );
369        }
370        print "Checks: $checkcount, Twins: $twin, Same job status: $same\n" ;
371
372    } elsif ($key eq 'l') {
373        print "Job keys:\n";
374        my $i = 0 ; my @list = sort(keys(%status)) ;
375        foreach $key (@list) {
376            print sprintf("%30s",$key), ++$i % 5 ? " " : "\n" ;
377        }
378        print "\n" if ($i % 5);
379
380    } elsif ($key eq 'm') {
381        print "Ref keys:\n" ;
382        my $i = 0 ; my @list = sort(keys(%ref)) ;
383        foreach $key (@list) {
384            print sprintf("%20s -> %5s",$key,$ref{$key}),
385                ++$i % 5 ? " | " : "\n" ;
386        }
387        print "\n" if ($i % 5);
388
389    } elsif ($key eq 'a' and $name) {
390        print "$name references:\n" ;
391        my $i = 0 ; my @list = grep {
392            $ref{$_} eq $name or
393            ($ref{$_} =~ /^\d+$/ and $name eq '_SID_'.$ref{$_})
394            } sort(keys(%ref)) ;
395        my $list_count = 0 ; my @chained = () ; # Search for chained refs
396        while ( @list + @chained != $list_count ) {
397            push @chained, @list ;
398            $list_count = @chained ;
399            @list = grep { $key = $ref{$_} ; grep { /^$key$/ } @list
400                } sort(keys(%ref)) ;
401        }
402        foreach $key (@chained) {
403            print sprintf("%40s",$key), ++$i % 5 ? " " : "\n" ;
404        }
405        print "\n" if ($i % 5);
406
407    } elsif ($key eq 'n' or $key eq 'p') {
408        if ( $key eq 'n') {
409            if ($index<0) {
410                $index = 0 ;
411            } elsif (keys(%status)>$index+10) {
412                $index += 10 ;
413            }
414        } elsif ($key eq 'p') {
415            if ($index>10) {
416                $index -= 10 ;
417            } else {
418                $index = 0 ;
419            }
420        }
421
422    } elsif ($key =~ /^\d$/) {
423        $selected = $index+$key ;
424        $status = $status{$status[$selected]} ;
425        $name = $status[$selected] ;
426
427    } elsif ($key eq 's') {
428        get_gdbm ;
429        my $tied = tied(%gdbm) ;
430        $tied->reorganize if (defined($tied) and confirm);
431        release_gdbm ;
432    }
433    } # End while actions
434}
435
436system "stty", 'icanon', 'eol', '^@' ;
Note: See TracBrowser for help on using the repository browser.