File Coverage

blib/lib/Cvs/Trigger.pm

Criterion	Covered	Total	%
statement	42	246	17.0
branch	0	54	0.0
condition	0	11	0.0
subroutine	14	34	41.1
pod	3	6	50.0
total	59	351	16.8

###########################################
package Cvs::Trigger;
###########################################

use strict;
use warnings;
use File::Spec;
use Log::Log4perl qw(:easy);
use Data::Dumper;
use Cache::FileCache;
use Storable qw(freeze thaw);
use POSIX;

our $VERSION = "0.04";

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        routines => { 'commitinfo' => \&commitinfo,
                      'loginfo'    => \&loginfo,
                      'verifymsg'  => \&verifymsg,
                    },
        cache_default_expires_in  => 3600,
        cache_auto_purge_interval => 1800,
        cache_namespace           => "cvs",
        %options,
    };

    if($self->{cache}) {
        $self->{file_cache} = Cache::FileCache->new({
                namespace           => $self->{cache_namespace},
                default_expires_in  => $self->{cache_default_expires_in},
                auto_purge_interval => $self->{cache_auto_purge_interval},
        });
    }

    bless $self, $class;
}

###########################################
sub parse {
###########################################
    my($self, $type, $opts) = @_;

    $type = $self->{type} unless defined $type;
    LOGDIE "No type defined" unless defined $type;

    if(exists $self->{routines}->{$type}) {
        DEBUG "Running $type (pid=$$ ppid=", getppid(), ")";
        $self->{routines}->{$type}->($self, $opts);
    } else {
        LOGDIE "Unknown type: $type";
    }
}

###########################################
sub commitinfo {
###########################################
    my($self, $opts) = @_;

    $opts ||= {};
    my $n_opt_args = ($opts->{n_opt_args} || 0);
    my $trigger = "commitinfo";
    my @nargv   = @ARGV[$n_opt_args .. $#ARGV];

    if(@nargv < 2) {
        LOGDIE "Argument error: $trigger expects at least 2 parameters ",
               "(got @nargv)";
    }

    my($repo_dir, @files) = @nargv;
    my @opts              = @ARGV[1 .. $n_opt_args-2];

    my $res = {
        repo_dir => $repo_dir,
        files    => \@files,
        opts     => \@opts,
        trigger  => $trigger,
        argv     => \@nargv,
    };

    if($self->{file_cache}) {
        $self->_cache_set($repo_dir, @files);
    }

    DEBUG "$trigger return parameters: ", Dumper($res);

    return $res;
}

###########################################
sub verifymsg {
###########################################
    my($self) = @_;

    DEBUG "Running verifymsg ($$ ", getppid(), ")";

    if(@ARGV < 1) {
        LOGDIE "Argument error: verifymsg expects at least 1 parameter";
    }

    my $tmp_file = $ARGV[-1];

    my $data = _slurp($tmp_file);

    my @opts = ();
    @opts = @ARGV[1 .. $#ARGV-1] if @ARGV > 1;

    my $res = {
        opts    => \@opts,
        message => $data,
    };

    if($self->{cache}) {
        $res->{cache} = $self->_cache_get();

        my $ttl = $self->_cache_ttl_dec();

        if($ttl < 1) {
            DEBUG "ttl=$ttl: Removing the cache for ", getppid();
            $self->{file_cache}->remove(getppid());
        } else {
            # Don't remove it yet, this could be a multi-dir check-in and
            # another verifymsg might be following and still rely on the cache.
            DEBUG "ttl=$ttl: Keeping the cache";
        }
    }

    DEBUG "verifymsg parameters: ", Dumper($res);
    return $res;
}

#2006/04/08 13:29:22 argv=verifymsg /tmp/cvsDYgcCY
#2006/04/08 13:29:22 Slurping data from /tmp/cvsDYgcCY
#2006/04/08 13:29:22 Read (7)[foobar.] from /tmp/cvsDYgcCY
#2006/04/08 13:29:22 data=foobar
#2006/04/08 13:29:22 Slurping data from /tmp/cvsDYgcCY
#2006/04/08 13:29:22 Read (7)[foobar.] from /tmp/cvsDYgcCY
#2006/04/08 13:29:22 msg=foobar
#2006/04/08 13:29:22 pid=20651 ppid=20644

###########################################
sub loginfo {
###########################################
    my($self, $opts) = @_;

    $opts ||= {};
    my $rev_fmt = ($opts->{rev_fmt} || undef);

    my @opts = @ARGV;

    my $data = join '', ;

    DEBUG "Running loginfo ($$ ", getppid(), "): argv=[@ARGV] data=[$data]";

    my $res = {
        opts    => \@opts,
    };

    $self->loginfo_message_parse($data, $res, $rev_fmt);

    DEBUG "loginfo returns ", Dumper($res);

    return $res;
}

###########################################
sub loginfo_message_parse {
###########################################
    my($self, $data, $res, $rev_fmt) = @_;

    DEBUG "Parsing $data";

    if(defined $rev_fmt) {
        if($rev_fmt ne "sVv") {
            LOGDIE "For now, only 'sVv' is supported ",
                   "as a revision info format (got '$rev_fmt')";
        }
            # Extract/remove first line
        my($line) = ($data =~ /(.*)/);
        $data =~ s/(.*)\n//;

        DEBUG "Extracted revision line $line";

        my($path, @fields) = split ' ', $line;
        for(@fields) {
            my($file, $rev1, $rev2) = split /,/, $_;
            $res->{revs}->{$file} = [$rev1, $rev2];
        }
    }

    if($data =~
         m#Update\sof\s(.*)\n
           In\sdirectory\s(.*?):(.*)\n\n
          #x) {
        $res->{repo_dir}  = $1;
        $res->{host}      = $2;
        $res->{local_dir} = $3;
    }

    if($data =~ m#Modified\sFiles:\n#gx) {
        while($data =~ /^\s+(.*)/mg) {
            my @files = split ' ', $1;
            push @{ $res->{files} }, @files;
        }
    }

    if($data =~ m#Log\sMessage:\n(.*)#sgx) {
        $res->{message} = $1;
    }

    return $res;
}

#Update of /tmp/vHmsem4xFV/cvsroot/m/a
#In directory mybox:/tmp/vHmsem4xFV/local_root/m/a
#
#Modified Files:
#       a1.txt
#Log Message:
#m/a/a1.txt-check-in-message

#2006/04/08 13:29:22 argv=loginfo
#2006/04/08 13:29:22 pid=20656 ppid=20653
#2006/04/08 13:29:22 stdin: a txt,1.20,1.21
#2006/04/08 13:29:22 stdin: Update of /home/mschilli/testcvs/a
#2006/04/08 13:29:22 stdin: In directory mybox:/mnt/big2/mschilli.do.not.delete/tmp/a
#2006/04/08 13:29:22 stdin:
#2006/04/08 13:29:22 stdin: Modified Files:
#2006/04/08 13:29:22 stdin:      txt
#2006/04/08 13:29:22 stdin: Log Message:
#2006/04/08 13:29:22 stdin: foobar
#2006/04/08 13:29:22 stdin:

###########################################
sub _slurp {
###########################################
    my($file) = @_;

    local $/ = undef;

    open FILE, "<$file" or
        LOGDIE "Cannot open $file ($!)";
    my $data = ;
    close FILE;

    return $data;
}

#2006/04/08 13:29:11 argv=commitinfo /home/mschilli/testcvs/a txt
#2006/04/08 13:29:11 Slurping data from /home/mschilli/testcvs/a
#2006/04/08 13:29:11 Read (0)[] from /home/mschilli/testcvs/a
#2006/04/08 13:29:11 data=
#2006/04/08 13:29:11 pid=20645 ppid=20644
#

###########################################
sub _cache_set {
###########################################
    my($self, $repo_dir, @files) = @_;

    my $ppid = getppid();

    my $cdata = $self->_cache_get();

    for my $file (@files) {
        DEBUG "Caching $repo_dir/$file under ppid=$ppid";

        push @{ $cdata->{$repo_dir} }, $file;
    }
    $cdata->{_ttl} += 1;
    DEBUG "Setting $ppid cache to ", Dumper($cdata);
    $self->{file_cache}->set($ppid, freeze $cdata);
}

###########################################
sub _cache_ttl_dec {
###########################################
    my($self) = @_;

    my $ppid = getppid();

    my $cdata = $self->_cache_get();
    $cdata->{_ttl}--;

    $self->{file_cache}->set($ppid, freeze $cdata);

    return $cdata->{_ttl};
}

###########################################
sub _cache_get {
###########################################
    my($self) = @_;

    my $ppid = getppid();

    my $cdata;

    if(my $c = $self->{file_cache}->get($ppid)) {
        DEBUG "Cache hit on ppid=$ppid";
        $cdata = thaw $c;
    } else {
        DEBUG "Cache miss on ppid=$ppid";
        $cdata = { _ttl => 0 };
    }

    return $cdata;
}

###########################################
package Cvs::Temp;
###########################################
use strict;
use warnings;
use File::Temp qw(tempdir);
use Sysadm::Install qw(:all);
use Log::Log4perl qw(:easy);
use Cwd;

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        dir => tempdir(CLEANUP => 1),
        %options,
    };

    $self->{cvsroot}     = "$self->{dir}/cvsroot";
    $self->{local_root}  = "$self->{dir}/local_root";
    $self->{out_dir}     = "$self->{dir}/out_dir";
    $self->{bin_dir}     = "$self->{dir}/bin";

    mkd $self->{local_root};
    mkd $self->{out_dir};
    mkd $self->{bin_dir};

    DEBUG "tempdir = $self->{dir}";

    $self->{cvs_bin}  = bin_find("cvs") unless defined $self->{cvs_bin};
    $self->{perl_bin} = bin_find("perl") unless
                        defined $self->{perl_bin};

    if(! defined $self->{cvs_bin}) {
        LOGDIE "Cannot find 'cvs' binary in your PATH.";
    }

    my($stdout, $stderr, $rc) = tap $self->{cvs_bin}, "-v";
    if($rc == 0 and $stdout =~ /(\d+\.\d+)/) {
        $self->{cvs_version} = $1;
    } else {
        LOGDIE "Cannot determine CVS version ($stderr)";
    }

    bless $self, $class;

    return $self;
}

###########################################
sub init {
###########################################
    my($self) = @_;

    $self->cvs_cmd("init");
    DEBUG "New cvs created in $self->{cvsroot}";

    cd $self->{local_root};
    $self->cvs_cmd("co", "CVSROOT");
    cdback;
}

###########################################
sub test_trigger_code {
###########################################
    my($self, $type, $cache, $parse_opt) = @_;

    my $script = <<'EOT';
_shebang_
use lib '_cwd_/blib/lib';
use lib '_cwd_/blib/arch';
use Cvs::Trigger qw(:all);
use YAML qw(DumpFile);
use Log::Log4perl qw(:easy);
Log::Log4perl->easy_init({ level => $DEBUG, file => ">>_logfile_",
        layout => "%F{1}-%L: %m%n" });
DEBUG "_type_ trigger starting @ARGV";
my $c = Cvs::Trigger->new(_cache_);
my $ret = $c->parse("_type_", _parse_opt_);
my $count = 1;
while(-f "_tmpfile_.$count") {
    $count++;
}
DEBUG "Creating _tmpfile_.$count";
DumpFile "_tmpfile_.$count", $ret;
EOT

    my $shebang = "#!" . $self->{perl_bin};
    $script =~ s/_shebang_/$shebang/g;

    $script =~ s#_tmpfile_#$self->{out_dir}/trigger.yml#g;
    $script =~ s#_cwd_#cwd()#ge;
    $script =~ s#_logfile_#$self->{out_dir}/log#g;
    $script =~ s/_type_/$type/g;
    if($cache) {
        $script =~ s/_cache_/cache => 1/g;
    } else {
        $script =~ s/_cache_//g;
    }

    if($parse_opt) {
        $script =~ s/_parse_opt_/$parse_opt/g;
    } else {
        $script =~ s/_parse_opt_/undef/g;
    }

    DEBUG "Test trigger code: $script";

    return $script;
}

###########################################
sub module_import {
###########################################
    my($self) = @_;

    DEBUG "Importing module";

    cd $self->{local_root};

    mkd "m/a/b";
    blurt "a1text", "m/a/a1.txt";
    blurt "a2text", "m/a/a2.txt";
    blurt "btext",  "m/a/b/b.txt";

    cd "m";
    $self->cvs_cmd("import", "-m", "msg", "m", "tag1", "tag2");
    cdback;

    cd $self->{local_root};
    rmf "m";
    cdback;

    $self->cvs_cmd("co", "m");
    cdback;
}

###########################################
sub files_commit {
###########################################
    my($self, @files) = @_;

    my $dir = $self->{local_root};
    cd $dir;

    for my $file (@files) {
        blurt rand(1E10), $file;
    }
    $self->cvs_cmd("commit", "-m", "@files-check-in-message", @files);

    cdback;
}

###########################################
sub single_file_commit {
###########################################
    my($self, $content, $file, $message) = @_;

    my $dir = $self->{local_root};
    cd $dir;

    blurt $content, $file;
    $self->cvs_cmd("commit", "-m", $message, $file);

    cdback;
}

###########################################
sub admin_rebuild {
###########################################
    my($self) = @_;

    my $dir = "$self->{local_root}/CVSROOT";
    cd $dir;

    $self->cvs_cmd("commit", "-m", "admin rebuild", ".");

    cdback;
}

###########################################
sub cvs_cmd {
###########################################
    my($self, @cmd) = @_;

    unshift @cmd, $self->{cvs_bin}, "-d", $self->{cvsroot};
    DEBUG "Running CVS command @cmd";

    my($stdout, $stderr, $rc) = tap @cmd;

    if($rc) {
        LOGDIE "@cmd failed: $stderr";
    }

    if($stderr) {
        ERROR "cvs cmd warning $stderr";
    }

    DEBUG "@cmd succeeded: $stdout";
}


###########################################
sub loginfo_line {
###########################################
    my($self, $script) = @_;

    # The CVS folks had the glorious idea to change the loginfo format
    # in 1.12 in a non-backward-compatible way. What were they thinking?
    if($self->{cvs_version} < 1.12) {
        return "DEFAULT ((echo %{sVv}; cat) | $script)";
    }

    return "DEFAULT ((echo %1{sVv}; cat) | $script)";
}

###########################################
sub latest_yml {
###########################################
    my($self, $index) = @_;

    my $dir = $self->{out_dir};
    my @ymls = sort { -M $b <=> -M $a } <$dir/trigger.yml.*>;

    $index = -1 unless defined $index;

    return $ymls[$index];
}

1;

__END__