File Coverage

blib/lib/VCS/Lite/Element.pm

Criterion	Covered	Total	%
statement	222	238	93.2
branch	78	106	73.5
condition	30	40	75.0
subroutine	22	23	95.6
pod	7	7	100.0
total	359	414	86.7

package VCS::Lite::Element;

use strict;
use warnings;

our $VERSION = '0.11';

#----------------------------------------------------------------------------

use File::Spec::Functions qw(splitpath catfile catdir catpath rel2abs);
use Time::Piece;
use Carp;
use VCS::Lite;
use Params::Validate qw(:all);
use Cwd qw(abs_path);

use base qw(VCS::Lite::Common);

#----------------------------------------------------------------------------

sub new {
    my $pkg  = shift;
    my $file = shift;
    my %args = validate ( @_,
        {
            store => {
                type    => SCALAR | OBJECT,
                default => $pkg->default_store,
            },
            verbose     => 0,
            recordsize  => 0, #ignored unless VCS::Lite::Element::Binary
        } );
    my $lite = $file;
    my $verbose = $args{verbose};

    $file = rel2abs($file);
    my $store_pkg;
    if (ref $args{store}) {
        $store_pkg = $args{store};
    } else {
        $store_pkg = ($args{store} =~ /\:\:/) ? $args{store} : "VCS::Lite::Store::$args{store}";
        eval "require $store_pkg";
        warn "Failed to require $store_pkg\n$@" if $@;
    }

    my $ele = $store_pkg->retrieve($file);
    if ($ele) {
        $ele->path($file);
        return $ele;
    }

    my $proto = bless {
        %args,
        path => $file,
    }, $pkg;

    $ele = $store_pkg->retrieve_or_create($proto);

    $ele->{path} = $file;

    if (!ref $lite) {
        unless (-f $file) {
            open FIL, '>', $file or croak("Failed to create $file, $!");
            close FIL;
        }
        $lite = $ele->_slurp_lite($file);
    } else {
        $file = $lite->id;  # Not handled at present
    }

    $ele->_assimilate($lite);
    $ele->save;

    $ele->{verbose} = $verbose;
    $ele;
}

sub check_in {
    my $self = shift;
    my %args = validate ( @_,
        {
            check_in_anyway => 0,
            description     => { type => SCALAR },
        } );
    my $file = $self->{path};

    my $lite = $self->_slurp_lite($file);

    my $newgen = $self->_assimilate($lite);
    return if !$newgen && !$args{check_in_anyway};

    $self->_mumble("Check in $file");
    $self->{generation} ||= {};
    my %gen = %{$self->{generation}};
    $gen{$newgen} = {
        author => $self->user,
        description => $args{description},
        updated => localtime->datetime,
    };

    $self->{latest} ||= {};
    my %lat = %{$self->{latest}};
    $newgen =~ /(\d+\.)*\d+$/;
    my $base = $1 || '';
    $lat{$base}=$newgen;

    $self->_update_ctrl( generation => \%gen, latest => \%lat);
    $newgen;
}

sub repository {
    my $self = shift;

    my ($vol,$dir,$fil) = splitpath($self->{path});
    my $repos_path = $vol ? catdir($vol,$dir) : $dir;

    VCS::Lite::Repository->new($repos_path, verbose => $self->{verbose});
}

sub traverse {
    undef;
}

sub fetch {
    my $self = shift;
    my %args = validate ( @_,
        {
            time        => 0,
            generation  => 0,
        } );

    my $gen = $args{generation} || $self->latest;

    if ($args{time}) {
        my $latest_time = '';
        my $branch = $args{generation} || '';
        $branch .= '.' if $branch;
        for (keys %{$self->{generation}}) {
            next unless /^$branch\d+$/;
            next if $self->{generation}{$_}{updated} > $args{time};
            ($latest_time,$gen) = ($self->{generation}{$_}{updated}, $_)
            if $self->{generation}{$_}{updated} > $latest_time;
        }
        return unless $latest_time;
    }
    return if $self->{generation} && !$self->{generation}{$gen};

    my $skip_to;
    my @out;
    for (@{$self->_contents}) {
        if ($skip_to) {
            if (/^=$skip_to$/) {
                undef $skip_to;
            }
            next;
        }
        if (my ($type,$gensel) = /^([+-])(.+)/) {
            if (_is_parent_of($gensel,$gen) ^ ($type eq '+')) {
                $skip_to = $gensel;
            }
            next;
        }
        next if /^=/;

        if (/^ /) {
            push @out,substr($_,1);
        }
    }

    my $file = $self->{path};
    VCS::Lite->new("$file\@\@$gen",undef,\@out);
}

sub commit {
    my ($self,$parent) = @_;

    my ($vol,$dir,$file) = splitpath($self->path);
    my $updfile = catfile($parent,$file);
    my $chg = $self->fetch;
    my $before = VCS::Lite->new($updfile);
    return unless $before->delta($chg);

    $self->_mumble("Committing $file to $parent");

    my $out;
    open $out,'>',$updfile or croak "Failed to open $file for committing, $!";
    print $out $chg->text;
}

sub update {
    my ($self,$parent) = @_;

    my $file = $self->path;
    $self->_mumble("Updating $file from $parent");

    my ($vol,$dir,$fil) = splitpath($file);
    my $fromfile = catfile($parent,$fil);
    my $baseline = $self->{baseline} || 0;
    my $parbas = $self->{parent_baseline};

    my $orig = $self->fetch( generation => $baseline);
    my $parele = VCS::Lite::Element->new($fromfile, verbose => $self->{verbose});
    my $parfrom = $parele->fetch( generation => $parbas);
    my $parlat = $parele->latest($parbas);
    my $parto = $parele->fetch( generation => $parlat);
    my $origplus = $parfrom->merge($parto,$orig);

    my $chg = VCS::Lite->new($file);
    my $merged = $orig->merge($origplus,$chg);
    my $out;
    open $out,'>',$file or croak "Failed to write back merge of $fil, $!";
    print $out $merged->text;
    $self->_update_ctrl(baseline => $self->latest, parent_baseline => $parlat);
}

sub _check_out_member {
    my $self    = shift;
    my $newpath = shift;
    my %args = validate(@_,
        {
            store => { type => SCALAR|OBJECT, optional => 1 },
        } );

    my $repos = VCS::Lite::Repository->new(
        $newpath,
        verbose => $self->{verbose},
        %args);

    my ($vol,$dir,$fil) = splitpath($self->path);
    my $newfil = catfile($newpath,$fil);
    my $out;
    open $out,'>',$newfil or croak "Failed to check_out $fil, $!";
    print $out $self->fetch->text;
    close $out;

    my $pkg = ref $self;
    $pkg->new($newfil,%args);
}

sub _assimilate {
    my ($self,$lite,%args) = @_;

    my @newgen = map { [' '.$_] } $lite->text;
    my (@oldgen,@openers,@closers,$skip_to);
    my $genbase = $args{generation} || $self->latest;

    if (my $cont = $self->_contents) {
        for (@$cont) {
            if ($skip_to) {
                push @openers, $_;
                if (/^=$skip_to$/) {
                    undef $skip_to;
                }
                next;
            }
            if (my ($type,$gen) = /^([+-])(.+)/) {
                $oldgen[-1][2] = [@closers] if @closers;
                @closers = ();
                push @openers, $_;
                if (_is_parent_of($gen,$genbase) ^ ($type eq '+')) {
                    $skip_to = $gen;
                }
                next;
            }
            if (my ($gen) = /^=(.+)/) {
                push @closers, $_;
                next;
            }
            if (/^ /) {
                $oldgen[-1][2] = [@closers] if @closers;
                push @oldgen,[$_, [@openers]];
                @openers = @closers = ();
                next;
            }
            croak "Invalid format in element contents";
        }
        $oldgen[-1][2] = [@closers] if @closers;
    } else {
        $self->_contents([map $_->[0], @newgen]);
        return 1;
    }

    $genbase =~ s/(\d+)$/$1+1/e;
    my @sd = Algorithm::Diff::sdiff( \@oldgen, \@newgen, sub { $_[0][0] });
    my (@newcont,@pending);
    my $prev = 'u';
    my $changed = 0;

    for (@sd) {
        my ($ind,$c1,$c2) = @$_;
        my @res1;
        if ($c1) {
            @res1 = (@{$c1->[1]},$c1->[0]);
            push @res1,@{$c1->[2]} if defined $c1->[2];
        }
        my $res2 = $c2->[0] if $c2;

        push @newcont,"=$genbase\n" if ($prev ne 'u') && ($ind ne $prev);
        if (@pending && ($ind ne 'c')) {
            push @newcont, @pending, "=$genbase\n";
            @pending=();
        }
        if (($prev =~ /[u+]/) && ($ind =~ /[c-]/)) {
            push @newcont,"-$genbase\n";
            $changed++;
        }
        if ($ind eq '+') {
            push @newcont,"+$genbase\n" if ($prev ne $ind);
            push @newcont, $res2;
            $changed++;
        } else {
            push @newcont, @res1;
        }
        if ($ind eq 'c') {
            push @pending,"+$genbase\n" if ($prev ne $ind);
            push @pending, $res2;
        }
        $prev = $ind;
    }

    push @newcont,"=$genbase\n" if ($prev ne 'u');
    return unless $changed;
    $self->_contents(\@newcont);
    $genbase;
}

sub _is_parent_of {
    my ($gen1,$gen2) = @_;

    my @g1v = split /\./,$gen1;
    my @g2v = split /\./,$gen2;
    (shift @g1v,shift @g2v) while @g1v && @g2v && ($g1v[0] eq $g2v[0]);

    return 1 unless @g2v;
    return 0 unless @g1v;
    return 0 if @g1v > 1;

    $g1v[0] < $g2v[0];
}

sub _update_ctrl {
    my ($self,%args) = @_;

    my $path = $args{path} || $self->{path};
    my ($vol,$dir,$fil) = splitpath($path);
    $self->{$_} = $args{$_} for keys %args;
    $self->{updated} = localtime->datetime;
    $self->save;
}

sub _contents {
    my $self = shift;

    $self->{contents} = shift if @_;
    return unless exists $self->{contents};

    $self->{contents};
}

sub _slurp_lite {
    my ($self,$name) = @_;

    VCS::Lite->new($name);
}

1;

__END__