VCS::Lite::Element - Minimal Version Control System - Element object

VCS-Lite-Repository documentation Contained in the VCS-Lite-Repository distribution.

Index

Code Index:

NAME

Top

VCS::Lite::Element - Minimal Version Control System - Element object

SYNOPSIS

Top

  use VCS::Lite::Element;
  my $ele=VCS::Lite::Element->new('/home/me/dev/testfile.c');
  my $lit=$ele->fetch( generation => 2);
  $ele->check_in( description => 'Fix the bug');
  $ele->update;
  $ele->commit;

DESCRIPTION

Top

A VCS::Lite::Repository contains elements corresponding to the source files being version controlled. The files are real files on the local file system, but additional information about the element is held inside the repository.

This information includes the history of the element, in terms of its generations.

new

  my $ele=VCS::Lite::Element->new('/home/me/dev/testfile.c');

Constructs a VCS::Lite::Element for a given element in a repository. Returns undef if the element is not found in the repository.

fetch

  my $lit=$ele->fetch( generation => 2);
  my $lit2=$ele->fetch( time => '2003-12-29T12:01:25');

The fetch method is used to retrieve generations from the repository. If no time or generation is specified, the latest generation is retrieved. The method returns a VCS::Lite object if successful or undef.

check_in

  $ele->check_in( description => 'Fix bug in foo method');

This method creates a new latest generation in the repository for the element.

update

  $ele->update;

This applies any changes to $ele which have happened in the parent repository, i.e. the one that the current repository was checked out from.

commit

  $ele->commit;

Applies the latest generation change to the parent repository. Note: this updates the file inside the parent file tree; a call to update is required to update the repository.

COPYRIGHT

Top

   Copyright (C) 2003-2004 Ivor Williams (IVORW (at) CPAN {dot} org)
   All rights reserved.

   This module is free software; you can redistribute it and/or modify it
   under the same terms as Perl itself.

SEE ALSO

Top

VCS::Lite::Repository, VCS::Lite.

VCS-Lite-Repository documentation Contained in the VCS-Lite-Repository distribution. 
package VCS::Lite::Element;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.08';

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 undef 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 undef unless $latest_time;
    }
    return undef 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 undef 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 undef unless exists $self->{contents};

    $self->{contents};
}

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

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

1;
__END__