view release on metacpan or  search on metacpan

lib/SVK/Path/Checkout.pm  view on Meta::CPAN

__PACKAGE__->mk_shared_accessors(qw(xd));
__PACKAGE__->mk_clonable_accessors(qw(report source copath_anchor copath_target));
__PACKAGE__->mk_accessors(qw(_pool _inspector));

use Class::Autouse qw(SVK::Editor::XD SVK::Root::Checkout);

use autouse 'SVK::Util' => qw( get_anchor catfile abs2rel get_encoder to_native );

=head1 NAME

SVK::Path::Checkout - SVK path class associating a checkout

=head1 SYNOPSIS

 See below

=head1 DESCRIPTION

The class represents a node in svk depot, associated with a checkout
copy.

=cut

sub real_new {
    my $class = shift;
    my $self = $class->SUPER::real_new(@_);
    unless (ref $self->report) {
	$self->report($self->_to_pclass($self->report))
	    if defined $self->report && length $self->report;
    }
    return $self;
}

sub root {
    my $self = shift;
    my $root = SVK::Root::Checkout->new({ path => $self });
    # XXX: It might not always be the case that we hold svk::path object
    # when using the root.
    use Scalar::Util 'weaken';
    weaken $root->{path};
    return $root;
}

sub _mkpath {
    my ($root, $path) = @_;
    my @path = ();
    for my $dir (File::Spec::Unix->splitdir($path)) {
	push @path, $dir;
	next unless length $dir;
	my $cur = File::Spec::Unix->catdir(@path);
	$root->make_dir($cur)
	    unless $root->check_path($cur);
    }
}

sub create_xd_root {
    my $self = shift;
    my $copath = $self->copath($self->copath_target);

    my (undef, $coroot) = $self->xd->{checkout}->get($copath, 1);
    Carp::cluck $copath.YAML::Syck::Dump($self->xd->{checkout}) unless $coroot;
    my @paths = $self->xd->{checkout}->find($coroot, {revision => qr'.*'});

    my $tmp = $self->_to_pclass($copath)->relative($coroot)->as_foreign('Unix')->absolute('/');
    $tmp = '' if $tmp eq '/';

    my $coroot_path = $self->path;
    $coroot_path =~ s/\Q$tmp\E$// or return $self->source->root;
    $coroot_path = '/' unless length $coroot_path;

    my $base_root = $self->source->root;
    return $base_root if $#paths <= 0;

    my $pool = SVN::Pool->new;
    my ($root, $base_rev);
    for (@paths) {
	$pool->clear;
	my $cinfo = $self->xd->{checkout}->get($_);
	my $path = abs2rel($_, $coroot => $coroot_path, '/');
	unless ($root) {
	    $root = $base_root->txn_root($self->pool);;
	    if ($base_root->revision_root_revision == 0) {
		# for interrupted checkout, the anchor will be at rev 0
		_mkpath($root, $path);
		$base_rev = 0;
	    }
	    else {
		$base_rev = $base_root->node_created_rev($path, $pool);
	    }
	    next;
	}
	my $parent = Path::Class::File->new_foreign('Unix', $path)->parent;
	if ($base_rev ==0 && !$root->check_path("$parent", $pool)) {
	    _mkpath($root, "$parent");
	}
	next if $cinfo->{revision} == $root->node_created_rev("$parent", $pool);
	my ($fromroot, $frompath) = $base_root->get_revision_root($path, $cinfo->{revision}, $pool);
	$root->delete($path, $pool)
	    if eval { $root->check_path ($path, $pool) != $SVN::Node::none };
	unless ($cinfo->{'.deleted'}) {
	    if ($frompath eq $path) {
		SVN::Fs::revision_link( $fromroot->root,
					$root->root, $path, $pool );
	    }
	    else {
		SVN::Fs::copy( $fromroot->root, $frompath,
			       $root->root, $path, $pool );
	    }
	}
    }
    return $root;
}

=head2 copath

Return the checkout path of the target, optionally with additional
path component.

=cut

my $_copath_catsplit = $^O eq 'MSWin32' ? \&catfile :
sub { defined $_[0] && length $_[0] ? "$_[0]/$_[1]" : "$_[1]" };

sub copath {
    my $self = shift;
    my $copath = ref($self) ? $self->copath_anchor : shift;
    my $paths = shift;
    return $copath unless defined $paths && length $paths;
    return $_copath_catsplit->($copath, $paths);
}

sub report { __PACKAGE__->make_accessor('report')->(@_) }

sub report_copath {
    my ($self, $copath) = @_;
    my $report = length($self->report) ? $self->report : undef;
    my $rel = abs2rel( $copath, $self->copath_anchor => $report );
    # XXX: abs2rel from F::S already does this.  tweak S::U abs2rel
    # and usage properly