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

#! /usr/bin/perl
#
# Copyright (c) 2004-2007 - Consultas, PKG.fr
#
# This file is part of A2P.
#
# A2P is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# A2P is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with A2P; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id: dbm-status-tools.pl 3 2007-10-18 16:20:19Z guillaume $
#

use strict ;
use Time::HiRes qw( usleep gettimeofday tv_interval) ;
use Fcntl qw(:flock);
use GDBM_File ;
use Storable qw( freeze thaw );
use Data::Dumper;
use A2P::Globals ;
use A2P::Status ;
use A2P::JobStatus ;

my $jobstatus_base = A2P::JobStatus::dbm_base() ;

$LOCKID = shift @ARGV if @ARGV ;

my $gdbm = ( $LOCKID =~ /^\// and -e $LOCKID )?
    $LOCKID : $jobstatus_base . $LOCKID ;

# Check file is really a dbm file with 'file' command
my @control = qx/file $gdbm/ =~ /(dbm).*(database)/i ;

unless ( -e $gdbm and @control == 2 ) {
    die "File $gdbm not found\n" .
        "First argument must be the LOCKID for which you to manage status\n" ;
}

print "Reading $gdbm memory file (".(-s $gdbm).")\n" ;
my %gdbm ;

sub error {
    map { print "$_\n" } @_ ;
    return 0 ;
}

my $LCK ;
my ( $uid, $gid );
sub get_gdbm {
    return error("File $gdbm doesn't exist")
        unless -e $gdbm ;
    my @stat = stat $gdbm ;
    ( $uid, $gid ) = @stat[4..5] ;
    open $LCK, '>', $gdbm . '.LCK'
        or return error("Can't open " . $gdbm . ".LCK locking file: $!");
    flock $LCK, LOCK_EX
        or return error("Can't lock on " . $gdbm . ".LCK: $!");
    tie %gdbm, "GDBM_File", $gdbm, GDBM_WRITER, 0666
        or return error("Can't tie $gdbm gdbm: $!");
    1 ;
}

sub release_gdbm {
    untie %gdbm ;
    flock $LCK, LOCK_UN ;
    close($LCK);
    chown $uid, $gid, $gdbm ;
}

sub dump_status {
    my $this = shift or return "" ;
    my $dirty = "_".$this->dirty_bit()."_".$this->dirty_bit(3)."____" ;
    return $this->get_sid_key.": Job ".$this->is_job.
        " [$this->{STATUS}] step=$this->{STEP}: ".
        " (".join('',@{$this->{STATE}}).") [Rev$this->{REV}; Sid:$this->{SID} ;"
        ." dirty bits: $dirty ]" ;
}

sub confirm {
    print "Are you sure to do this [y/N] ?" ;
    my $response = lc(getc);
    print "\n" ;
    return $response eq 'y' ? 1 : 0 ;
}

# Prepare cache and A2P::Status privates
my $cache = { __GDBM_WRITER__ => 1 };
my $s = new A2P::Status($cache,\%gdbm,'init');
$s->remove_from_cache ;

my $quit = 0 ;
my $index = -1 ;
my $selected = -1 ;
my $status ;
my $name ;

while (!$quit) {

    sleep 1 and next unless (&get_gdbm());

    my @keys = sort(keys(%gdbm)) ;
    print "===== Service $LOCKID =====\n",
        "Memory DB keys: ",scalar(@keys)," found\n" ;

    my %keys = map { $_ => 1 } @keys ;
    my @lost = () ;
    my %rev  = map {
        delete $keys{$_} ;
        /^(.+)_rev$/ ;
        push @lost , $_ unless (exists($gdbm{$1}));
        $_ => thaw($gdbm{$_})
        } grep { /_rev$/ } @keys ;

    print "Lost revisions (".scalar(@lost)."): @lost\n"
        if ( @lost = sort(@lost) );

    my %ref = map {
        delete $keys{$_} ;
        $_ => $gdbm{$_}
    } grep { ($gdbm{$_} =~ /^\d+$/ and exists($gdbm{'_SID_'.$gdbm{$_}})) or
                exists($gdbm{$gdbm{$_}}) } keys(%keys) ;
    my @ref = sort(keys(%ref)) ;
    print "References found: ", scalar(@ref), "\n" ;

    my %status = map {
        delete $keys{$_} ;
        $_ => thaw($gdbm{$_})
    } grep { $gdbm{$_} =~ /\x04/ } keys(%keys) ;
    my @status = sort(keys(%status)) ;
    print "Status    found: ", scalar(@status), "\nRevisions found: ",
        scalar(keys(%rev)), "\n" ;
    my $count = 2*@status + @ref ;
    if ( $count == @keys ) {
        print "Count is coherent\n" ;
    } else {
        print "Bad count found: ".(@keys - $count)." more keys found\n" ;
    }

    my @unexpected = sort(keys(%keys)) ;
    print "Not expected keys: @unexpected\n" if @unexpected;

    my $_SID_count = grep { /^_SID_(\d+)$/ } keys(%status) ;
    my $_SID_rev_count = grep { /^_SID_(\d+)_rev$/ } keys(%rev) ;
    print "_SID_# count: $_SID_count (+$_SID_rev_count _rev)\n" ;

    &release_gdbm() ;

    if ($selected>=0) {
        $name = $status[$selected] ;
        $status = $status{$name} ;

    } elsif ($selected > $#status) {
        $selected = $#status ;
        $name = $status[$selected] ;
        $status = $status{$name} ;
    }

    unless (defined($status[$selected]) and $name == $status[$selected]) {
        $selected = -1 ;
        $name = $status = undef ;
    }

    # Actions
    my $a = 0 ;
    while (!$quit) {
    print "\n",
          "q -> Quit             l -> list jobs      m -> list refs         \n",
          "r -> Refresh          e -> evaluation     j -> select a job      \n",
          "s -> Shrink dbm       d -> delete job     v -> validate job      \n",
          "a -> list job refs    x -> dump dbm keys  u -> unselect job      \n",
          "t -> list twin jobs                                              \n",
          "f -> Flush lost/unexpected or done                               \n",
          "[0-9] -> select a job  n/p -> next/previous indexed jobs list    \n"
          unless ( $a ++ % 5 );
    if ($index>=0) {
        print "Current index = $index\n" ;
        for my $i ( 0..9 ) {
            if (defined($status[$index+$i])
            and exists($status{$status[$index+$i]})) {
                my $this = $status{$status[$index+$i]} ;
                print "$i - ",dump_status($this),"\n" ;
            } elsif (defined($status[$index+$i])) {
                print "$i - Unavailable ",$status[$index+$i],"\n" ;
            }
        }
    }
    print "DB memory file size: ".(-s $gdbm)."\n" ;
    print "Selected job '$name': ", dump_status($status), "\n", Dumper($status),
        "('$name' selected, type 'u' to unselect it)\n"
        if (defined($name) and defined($status));
    print "Command ? " ;
    system "stty", '-icanon', 'eol', "\001";
    my $key = lc(getc) ;
    print "\n" ;

    $quit ++ if ($key eq 'q'); # Quit
    last     if ($key eq 'r'); # Refresh

    if ($key eq 'j') {
        print "Job: " ;
        system "stty", 'icanon', 'eol', '^@' ;
        my $job = <STDIN> ;
        chomp($job);
        if (exists($status{$job})) {
            $status = $status{$job} ;
        } else {
            print "$job doesn't exists\n";
        }

    } elsif ($key eq 'u') {
        undef $name ;
        undef $status ;
        $selected = -1 ;

    } elsif ($key eq 'e') {
        print "Evaluation: " ;
        system "stty", 'icanon', 'eol', '^@' ;
        my $eval = <STDIN> ;
        chomp($eval);
        print eval $eval, "\n" ;

    } elsif ($key eq 'v' and defined($name) and defined($status)) {
        get_gdbm ;
        if (tied(%gdbm) and confirm) {
            $status->{STATUS} = 'DONE' ;
            $status->{STATE}->[12] = 'o' ;
            $status->{REV} += 100 ;
            $status->set_dirty_bit(3) ;
            $status->cache_timer ;
            $gdbm{$name} = freeze($status) ;
        }
        release_gdbm ;
        last ; # Refresh

    } elsif ($key eq 'd' and defined($name) and defined($status)) {
        get_gdbm ;
        $status->remove_from_tied_hash if (tied(%gdbm) and confirm);
        release_gdbm ;
        # Select next
        $selected += $selected < $#status ? 1 : -1 ;
        $status = $status{$status[$selected]} ;
        $name = $status[$selected] ;
        last ; # Refresh

    } elsif ($key eq 'f') {
        get_gdbm ;
        if (tied(%gdbm) and confirm) {
            if (@lost or @unexpected) {
                map { print '*' ; delete $gdbm{$_} } @lost ;
                map { print '+' ; delete $gdbm{$_} } @unexpected ;

            } else {
                my $stop = 0 ;
                $SIG{INT} = sub { $stop ++ } ;
                my $i = 0 ;
                $| = 1 ;
                foreach $name (keys(%status)) {
                    $status = $status{$name} ;
                    last if $stop ;
                    if ($status->is_abterm
                    or $status->step_status(12) ne 'o') {
                        print '-' ;
                    } else {
                        delete $gdbm{$name} ;
                        print '*' ;
                    }
                    print ++$i % 100 ? "" : "\n" ;
                }
            }
            print "\n" ;
        }
        release_gdbm ;
        # Remove any selection
        $selected = -1 ;
        $status = $name = undef ;
        last ; # Refresh

    } elsif ($key eq 'x') {
        get_gdbm ;
        print "Warning: You must abort quickly dumping if service is running\n",
            "Gdbm dump:\n";
        my ( $i, $l, $line ) = ( 0, 0, 0 ) ;
        my @list = sort(keys(%gdbm)) ;
        foreach $key (@list) {
            my $L = length($key)>30 ? 1 : 0 ;
            if ($l or $L) {
                print "\n" ;
                $i = 0 ;
                $l = $L ;
                $line ++ ;
            }

            # Extract comprehensible value
            my $value = ref($gdbm{$key}) || $gdbm{$key} ;
            #$value = ref($value)
            $value = ref(thaw($value)) if ( $value =~ /\x04/ );

            # Keep value as a 30 chars length string
            my $text = sprintf(": %-26s| ",substr($value,0,26)) ;

            print sprintf("%30s%s",$key,$text);

            # Avoid to output pres a key message when line=0
            if ( ++$i % 3 ) {
                next ;

            } else {
                print "\n" ;
                $line ++ ;
            }

            unless ( $line % 20 ) {
                print "
                    [ Press any key to continue but [a] to abort the dump ]" ;
                system "stty", '-icanon', 'eol', "\001";
                my $press = lc(getc) ;
                last if ( $press eq 'a' );
                print "\n" ;
                ( $i, $l ) = ( 0, 0 ) ;
            }
        }
        print "\n" ;
        release_gdbm ;

    } elsif ($key eq 't') {
        print "Twin status:\n";
        my ( $twin, $same, $checkcount ) = ( 0, 0, 0 );
        my %done = () ;
        my @list = sort(keys(%status)) ;
        my $listtotal = 0 ;
        $| = 1 ;
        foreach my $check (@list) {
            foreach my $cmp
            (grep { ! exists($done{'__'.$check.'__'.$_.'__'}) } @list) {
                # Don't compare on the same key
                next if ( $check eq $cmp );

                # Don't compare if still compared
                $done{'__'.$cmp.'__'.$check.'__'} = 1 ;

                if ( $status{$check} eq $status{$cmp} ) {
                    print "$check and $cmp are twins\n" ;
                    $twin ++ ;

                } elsif ( $status{$check}->{JOBID} eq $status{$cmp}->{JOBID} ) {
                    print "$check and $cmp are for the same job, but with ",
                        $status{$check}->{REV}, " vs ", $status{$cmp}->{REV},
                        " revision, and ", $status{$check}->{STEP}, ":'",
                        $status{$check}->step_status($status{$check}->{STEP}),
                        "' vs ", $status{$cmp}->{STEP}, ":'",
                        $status{$cmp}->step_status($status{$cmp}->{STEP}),
                        " step/status\n" ;
                    $same ++ ;
                }

                $checkcount ++ ;
            }
            print sprintf("%.2f%%  \r", ++$listtotal * 100 / @list );
        }
        print "Checks: $checkcount, Twins: $twin, Same job status: $same\n" ;

    } elsif ($key eq 'l') {
        print "Job keys:\n";
        my $i = 0 ; my @list = sort(keys(%status)) ;
        foreach $key (@list) {
            print sprintf("%30s",$key), ++$i % 5 ? " " : "\n" ;
        }
        print "\n" if ($i % 5);

    } elsif ($key eq 'm') {
        print "Ref keys:\n" ;
        my $i = 0 ; my @list = sort(keys(%ref)) ;
        foreach $key (@list) {
            print sprintf("%20s -> %5s",$key,$ref{$key}),
                ++$i % 5 ? " | " : "\n" ;
        }
        print "\n" if ($i % 5);

    } elsif ($key eq 'a' and $name) {
        print "$name references:\n" ;
        my $i = 0 ; my @list = grep {
            $ref{$_} eq $name or
            ($ref{$_} =~ /^\d+$/ and $name eq '_SID_'.$ref{$_})
            } sort(keys(%ref)) ;
        my $list_count = 0 ; my @chained = () ; # Search for chained refs
        while ( @list + @chained != $list_count ) {
            push @chained, @list ;
            $list_count = @chained ;
            @list = grep { $key = $ref{$_} ; grep { /^$key$/ } @list
                } sort(keys(%ref)) ;
        }
        foreach $key (@chained) {
            print sprintf("%40s",$key), ++$i % 5 ? " " : "\n" ;
        }
        print "\n" if ($i % 5);

    } elsif ($key eq 'n' or $key eq 'p') {
        if ( $key eq 'n') {
            if ($index<0) {
                $index = 0 ;
            } elsif (keys(%status)>$index+10) {
                $index += 10 ;
            }
        } elsif ($key eq 'p') {
            if ($index>10) {
                $index -= 10 ;
            } else {
                $index = 0 ;
            }
        }

    } elsif ($key =~ /^\d$/) {
        $selected = $index+$key ;
        $status = $status{$status[$selected]} ;
        $name = $status[$selected] ;

    } elsif ($key eq 's') {
        get_gdbm ;
        my $tied = tied(%gdbm) ;
        $tied->reorganize if (defined($tied) and confirm);
        release_gdbm ;
    }
    } # End while actions
}

system "stty", 'icanon', 'eol', '^@' ;