File Coverage

blib/lib/Archive/Tar/Merge.pm

Criterion	Covered	Total	%
statement	115	125	92.0
branch	30	42	71.4
condition	3	3	100.0
subroutine	16	16	100.0
pod	0	4	0.0
total	164	190	86.3

###########################################
package Archive::Tar::Merge;
###########################################

use strict;
use warnings;
use Archive::Tar::Wrapper;
use File::Temp qw(tempdir);
use Log::Log4perl qw(:easy);
use File::Spec::Functions qw(abs2rel);
use File::Spec;
use File::Find;
use Digest::MD5;
use File::Basename;
use Sysadm::Install qw(mkd);

our $VERSION = "0.01";

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

    my $self = {
        dest_tarball    => undef,
        source_tarballs => [],
        hook            => undef,
        %options,
    };

    if(@{ $self->{source_tarballs} } == 0) {
        LOGDIE "Need at least one tarball to merge";
    }

    for my $tarball (@{ $self->{source_tarballs} }) {
        if(! -f $tarball) {
            LOGDIE "Tarball not found: $tarball";
        }
    }

    bless $self, $class;

    $self->unpack_sources();
    return $self;
}

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

    for my $source_tarball (@{ $self->{source_tarballs} }) {
        my($tmpdir) = tempdir(CLEANUP => 1);

        my %source = ();

        $source{dir} = $tmpdir;

        my $arch = Archive::Tar::Wrapper->new(tmpdir => $tmpdir);
        $arch->read($source_tarball);

        $source{archive} = $arch;
        $source{tarball} = $source_tarball;

        push @{ $self->{sources} }, \%source;
    }
}

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

    my $out_dir = tempdir(CLEANUP => 1);
    my $out_tar = Archive::Tar::Wrapper->new(tmpdir => $out_dir);

    DEBUG "Merging tarballs ",
          join(', ', @{ $self->{source_tarballs} }), ".";

    my $paths     = {};

        # Build the following data structure:
        # rel/path1:
        #   digests => digest1 => abs/path1
        #              digest2 => abs/path2
        #   paths   => [abs/path1, abs/path2]
        # rel/path3:
        #   digests => digest3 => abs/path3
        #   paths   => [abs/path3]
        # ...
    for my $source (@{ $self->{sources} }) {
        my $dir = $source->{dir};
        find(sub {
            return unless -f;
            my $rel = abs2rel($File::Find::name, $dir);
              # Two down
            $rel =~ s#.*?/.*?/##;

            my $digest = file_hash($File::Find::name);

              # avoid autovivification
            if(!exists $paths->{$rel} or
               !exists $paths->{$rel}->{digests}->{$digest}) {
                  # create the data structure shown above
                $paths->{$rel}->{digests}->{$digest} = $File::Find::name;
                push @{$paths->{$rel}->{paths}}, $File::Find::name;
            }
        }, $dir);
    }

        # Traverse and figure out conflicts
    for my $relpath (keys %$paths) {

        my $dst_dir = File::Spec->catfile($out_dir, dirname($relpath));
        my @digests = keys %{$paths->{$relpath}->{digests}};

        my $dst_entry = File::Spec->catfile($dst_dir,
                                            basename($relpath));
        my $dst_content;

        mkd $dst_dir unless -d $dst_dir;

        my $src_entry = $paths->{$relpath}->{paths}->[0];

        if(-l $src_entry) {
            DEBUG "Symlinking $src_entry to $dst_entry";
            symlink(readlink($src_entry), $dst_entry) or
                LOGDIE("symlinking $dst_entry failed: $!");
            next;
        }

        if(@digests == 1) {

              # A unique file. Take it as-is, but call the
              # he hook if there's one defined.
            if(defined $self->{hook}) {
                my $hook = $self->{hook}->(
                    $relpath,
                    $paths->{$relpath}->{paths},
                    $out_tar,
                );

                if(0) {
                } elsif(defined $hook->{action}) {
                    if($hook->{action} eq "ignore") {
                        DEBUG "Ignoring $relpath per hook";
                        next;
                    } else {
                        LOGDIE "Unknown action from hook: ",
                               "$hook->{action}";
                    }
                } elsif(defined $hook->{content}) {
                    $dst_content = $hook->{content};
                } else {
                    # No action from hook, leave the file unmodified
                }
            }

        } else {

              # Several different versions of the file, call the
              # decider to pick one
            if(defined $self->{decider}) {
                my $decision = $self->{decider}->(
                    $relpath,
                    $paths->{$relpath}->{paths},
                    $out_tar,
                );

                if(0) {
                } elsif(defined $decision->{action}) {
                    if($decision->{action} eq "ignore") {
                        DEBUG "Ignoring $relpath per decider";
                        next;
                    } else {
                        LOGDIE "Unknown action from decider: ",
                               "$decision->{action}";
                    }
                } elsif(defined $decision->{index}) {
                    $src_entry =
                        $paths->{$relpath}->{paths}->[ $decision->{index} ];

                } elsif(defined $decision->{content}) {
                    $dst_content = $decision->{content};
                } else {
                    LOGDIE "Decider failed to return decision";
                }
            } else {
                LOGDIE "Conflict: $relpath (and no decider defined)";
            }
        }

        if(defined $dst_content) {
            $out_tar->add($relpath, \$dst_content);
        } else {
            $out_tar->add($relpath, $src_entry);
        }
    }

    if(defined $self->{dest_tarball}) {
        my $compress = 0;
        if($self->{dest_tarball} =~ /gz$/) {
            $compress = 1;
        }

        $out_tar->write($self->{dest_tarball}, $compress);
    }

    return $out_tar;
}

######################################
sub file_hash {
######################################
    my($filename) = @_;

    open FH, "<$filename" or LOGDIE "Cannot open $filename";

    my $ctx = Digest::MD5->new();
    $ctx->addfile(*FH);
    my $digest = $ctx->hexdigest;

    close FH;

    return $digest;
}

1;

__END__