VCfs - Version Control agnostic interface on the local system

  my $vc = VCfs->new(".");
  my %status = $vc->status;
  my @tags = $vc->taglist;

  $vc = VCfs->new($dir|$file, \%options);

  $vc->detect;

  %res = $vc->_do_run(@command);

  $vc->get_log($target);

  $vc->get_log_times($target);

  my %vals = $vc->get_info;

  my @tags = $vc->taglist;

  my $dir = $vc->tag_dir;

  $vc->taggit($tagname, message => $message);

  $vc->add(@files);

  $vc->remove(@files);

  $vc->commit($message, @files);

  $vc->update;

  my @list = $vc->list($path);

  $vc->revert(@files);

  %status = $vc->status(@files);

  $vc->propget($propname, $url||$file);

  $vc->propset($propname, \@vals, @files);

  $vc->propset($propname, $valstring, @files);

package VCfs;
$VERSION = v0.0.1;

use warnings;
use strict;
use Carp;

use File::Basename qw(
  dirname
);

use IPC::Run ();

use Class::Accessor::Classy;
ro qw(
  dir
  vcs
  vcs_cmd
);
no  Class::Accessor::Classy;

sub new {
  my $caller = shift;
  my ($dir, $opts) = @_;
  my $class = ref($caller) || $caller;
  my $self = {$opts ? %$opts : ()};

  $dir or croak("constructor must have a directory or file");
  unless(-d $dir) {
    $dir = dirname($dir);
  }
  (-d $dir) or croak("eek");
  $self->{dir} = $dir;

  bless($self, $class);
  $self->detect;
  return($self);
} # end subroutine new definition
########################################################################

sub detect {
  my $self = shift;
  my $dir = $self->{dir};
  (-d $dir) or croak("eek");
  my %dmatches = (
    svn => "$dir/.svn",
    darcs => "$dir/_darcs",
    cvs => "$dir/CVS",
    );
  foreach my $k (keys(%dmatches)) {
    (-d $dmatches{$k}) and ($self->{vcs} = $k);
  }
  $self->{vcs} ||= 'svk'; # the oddball
  $self->{vcs_cmd} = $self->{vcs}; # XXX for now;
} # end subroutine detect definition
########################################################################

sub _do_run {
  my $self = shift;
  my @command = @_;
  my ($in, $out, $err);
  0 and warn "run $self->{vcs_cmd} @command\n";
  my $ret = IPC::Run::run([$self->vcs_cmd, @command], \$in, \$out, \$err);
  $ret or die "command died $err";
  return(out => $out, err => $err, status => ($? >> 8), ret => $ret);
} # end subroutine _do_run definition
########################################################################

foreach my $type (qw(svn svk cvs darcs)) {
  no strict 'refs';
  *{__PACKAGE__ . "::is_$type"} = sub {
    my $self = shift;
    return($self->{vcs} eq $type);
  }; # end sub
}

sub get_log {
  my $self = shift;
  my ($target, %opts) = @_;

  my @args = $opts{args} ? @{$opts{args}} : ();

  my ($in, $out, $err);
  IPC::Run::run(
    [$self->vcs_cmd, 'log', ($self->is_svk ? '-x' : ()), @args, $target],
    \$in, \$out, \$err
    );
  $err and warn "eek! $err ";
  # warn "see: $out";
  # XXX error checking?
  # XXX wantarray?
  return(split(/\n/, $out));
} # end subroutine get_log definition
########################################################################

sub get_log_times {
  my $self = shift;
  # XXX maybe want this regex for other things? - get_summary_lines ?
  my @l = grep(/^r\d+:?.*\|\s/,
    $self->get_log(@_)
    );
  my @times;
  foreach my $s (@l) { # XXX also, usable in other areas
    if($self->is_svk) {
      $s =~ s/^(r\d+):\s*/$1 | /;
    }
    my ($r, $u, $d, $else) = split(/\s\|\s/, $s, 4);
    $else ||= '';
    #warn "split into ", join("#", $r, $u, $d, $else), "\n";
    push(@times, $d);
  }
  return(@times);
} # end subroutine get_log_times definition
########################################################################

sub get_info {
  my $self = shift;

  my %ans = $self->_do_run('info', $self->dir);
  my %info;
  foreach my $line (split(/\n/, $ans{out})) {
    my ($key, $val) = split(/ *: */, $line, 2);
    $key = lc($key);
    $key =~ s/ +/_/g;
    $key =~ s/__+/_/g;
    $key =~ s/[^a-z0-9_]+//g;
    exists($info{$key}) and die "oops $key twice in $ans{out}";
    $info{$key} = $val;
  }
  return(%info);
} # end subroutine get_info definition
########################################################################

sub taglist {
  my $self = shift;
  return(map({s#/$##;$_} $self->list($self->tag_dir)));
} # end subroutine taglist definition
########################################################################

sub tag_dir {
  my $self = shift;

  my %info = $self->get_info;
  my $url = $info{url};
  my $tagdir = $url;
  $tagdir =~ s/trunk$/tags\// or die "eek, $url not trunk?";
  return($tagdir);
} # end subroutine tag_dir definition
########################################################################

sub taggit {
  my $self = shift;
  my ($name, %opts) = @_;
  ($name =~ m#/#) and die "improper tagname $name";

  my %info = $self->get_info;
  my $url = $info{url};
  die "I can't taggit() on type ", $self->vcs_command, " yet"
    unless($url);

  # TODO svk support
  # TODO config-file and/or propval layout?

  my $trunk = $url; # could also be a branch I guess
  my $tagdir = $url;
  $tagdir =~ s{(?:trunk|branches/[^/]+)/?$}{tags/} or
    croak("eek, $url not trunk|branches?");
  my $tagdest = $tagdir . $name;

  # Bah! svn doesn't prevent copying into an existing tag directory (at
  # least not in any form that I can see.)
  #warn $self->list($tagdir);
  my @has = grep(/^\Q$name\E\/$/, $self->list($tagdir));
  @has and die "tag '$name' already exists in $tagdir";

  my $message = $opts{message};
  $message = "tagging $name" unless(defined($message));

  $self->_do_run('copy', $trunk, $tagdest, '--message', $message);
} # end subroutine taggit definition
########################################################################

sub add {
  my $self = shift;
  my @files = @_;
  my %r = $self->_do_run('add', @files);
  $r{err} and warn "eek! $r{err} ($r{status})";
  $r{ret} or warn "eek";
  # XXX or should parse output and return number of added files?
  return($r{ret});
} # end subroutine add definition
########################################################################

sub remove {
  my $self = shift;
  my @files = @_;
  my %r = $self->_do_run('remove', @files);
  $r{err} and warn "eek! $r{err} ($r{status})";
  $r{ret} or warn "eek";
  # XXX or should parse output and return number of added files?
  return($r{ret});
} # end subroutine remove definition
########################################################################

sub commit {
  my $self = shift;
  my ($message, @files) = @_;
  @files or die;
  my %r = $self->_do_run('commit', @files, '-m', $message);
  $r{err} and warn "eek! $r{err} ($r{status})";
  $r{ret} or warn "eek";
  # XXX or should return what?
  return($r{ret});
} # end subroutine commit definition
########################################################################

sub update {
  my $self = shift;

  my %r = $self->_do_run('update');
} # end subroutine update definition
########################################################################

sub list {
  my $self = shift;
  my ($path) = @_;
  $path or die; # XXX ?
  my %r = $self->_do_run('list', $path);
  #$r{err} and warn "eek! $r{err} ($r{status})";
  #$r{ret} or warn "eek";
  #$r{out} or warn "that's a problem";
  return(split(/\n/, $r{out}));
} # end subroutine list definition
########################################################################

sub revert {
  my $self = shift;
  my (@files) = @_;
  @files or die "need files";
  my %r = $self->_do_run('revert', @files);
  # TODO read the qr/Reverted '([^']+)'/ lines?
  warn $r{out};
} # end subroutine revert definition
########################################################################

sub status {
  my $self = shift;
  my @files = @_;
  my %r = $self->_do_run('status', @files);
  $r{err} and warn "eek! $r{err} ($r{status})";
  $r{ret} or warn "eek";
  $r{out} or return();
  return(map({reverse(split(/\s+/, $_, 2))}
      split(/\n/, $r{out})
    ));
} # end subroutine status definition
########################################################################

sub propget {
  my $self = shift;
  my ($prop, $file) = @_;

  my %r = $self->_do_run('propget', $prop, $file);
  defined(my $string = $r{out}) or croak("nothing there");

  die "this is unfinished";


} # end subroutine propget definition
########################################################################

sub propset {
  my $self = shift;
  my ($prop, $val, @files) = @_;
  if(ref($val)) {
    UNIVERSAL::isa($val, 'ARRAY') or die;
    $val = join("\n", @$val);
  }
  my %r = $self->_do_run('propset', $prop, $val, @files);
  $r{err} and warn "eek! $r{err} ($r{status})";
  $r{ret} or warn "eek";
  return($r{ret});
} # end subroutine propset definition
########################################################################

# vi:sw=2:ts=2:et:sta
1;