view release on metacpan or  search on metacpan

SyncTree.pm  view on Meta::CPAN

	    $ln->args($txt, $lnk)->system;
	}
    }
}

sub subtract {
    my $self = shift;
    return unless $self->{ST_SUB};
    my $ct = $self->clone_ct;
    my %co = map {$_ => 1} $self->_lsco;
    my $exnames = $self->{ST_SUB}->{exfiles}; # Entries to remove
    my (%dir, %keep); # Directories respectively to inspect, and to keep
    $dir{dirname($_)}++ for keys %{$exnames};
    $dir{$_}++ for keys %{$self->{ST_SUB}->{dirs}}; # Existed originally
    my $dbase = $self->dstbase;
    for my $d (sort {$b cmp $a} keys %dir) {
	next if $keep{$d};
	my ($k) = ($d =~ m%^\Q$dbase\E/(.*)$%);
	if ($k and $self->{ST_SRCMAP}->{$k}) {
	    delete $exnames->{$d};
	    my $dad = $d;
	    $keep{$dad}++ while $dad = dirname($dad) and $dad gt $dbase;
	    next;
	}
	if (opendir(DIR, $d)) {
	    my @entries = grep !/^\.\.?$/, readdir DIR;
	    closedir(DIR);
	    map { $_ = join('/', $d, $_) } @entries;
	    if (grep { !$exnames->{$_} and $ct->ls(['-s'], $_)->qx !~ /\@$/}
		  @entries) { # Something not to delete--some version selected
		my $dad = $d;
		$keep{$dad}++ while $dad = dirname($dad) and $dad gt $dbase;
	    } else {
		if (@entries) {
		    my @co = grep {$co{$_}} @entries; # Checkin before removing
		    $ct->ci($self->comment, @co)->system if @co;
		    delete @$exnames{@entries}; # Remove the contents
		}
		$exnames->{$d}++; # Add the container
	    }
	}
    }
    delete @$exnames{keys %keep};
    my @exnames = keys %{$exnames};
    for my $dad (map {dirname($_)} @exnames) {
	$self->branchco(1, $dad) unless $co{$dad}++;
    }
    # Force because of possible checkouts in other views. Fail for unreachable
    $ct->rm([@{$self->comment}, '-f'], @exnames)->system if @exnames;
}

sub label {
    my $self = shift;
    my $lbtype = shift || $self->lbtype;
    return unless $lbtype;
    my $dbase = $self->dstbase;
    my $ct = $self->clone_ct({autochomp=>0});
    my $ctq = $self->clone_ct({stdout=>0});
    my $ctbool = $self->clone_ct({autofail=>0, stdout=>0, stderr=>0});
    my $dvob = $self->dstvob;
    my $locked;
    if ($ctbool->lstype(['-s'], "lbtype:$lbtype\@$dvob")->system) {
	$ct->mklbtype($self->comment, "lbtype:$lbtype\@$dvob")->system;
    } elsif (!$self->inclb) {
	$locked = $ct->lslock(['-s'], "lbtype:$lbtype\@$dvob")->qx;
	$ct->unlock("lbtype:$lbtype\@$dvob")->system if $locked;
    }
    # Allow for labelling errors, in case of hard links: only the link
    # recorded can be labelled, the other being seen as 'removed'
    if ($self->label_mods || $self->inclb) {
	my @mods = $self->_lsco;
	push @mods, @{$self->{ST_LBL}} if $self->{ST_LBL};
	if (@mods) {
	    $ctbool->mklabel([qw(-nc -rep), $self->inclb], @mods)->system
	                                                      if $self->inclb;
	    $ctbool->mklabel([qw(-nc -rep), $lbtype], @mods)->system;
	}
    } else {
	my $lbl = $self->lblver;
        if ($lbl) {
	    my $ct = $self->clone_ct({autochomp=>1, autofail=>0, stderr=>0});
	    my @rv = grep{ s/^(.*?)(?:@@(.*))/$1/ &&
			     ($2 =~ /CHECKEDOUT$/ || !-r "$_\@\@/$lbl") }
	      $ct->ls([qw(-r -vob -s)], $dbase)->qx,
	      $ct->ls([qw(-d -vob -s)], $dbase)->qx;
	    $ctbool->mklabel([qw(-nc -rep), $lbtype], $dbase, @rv)->system;
        } else {
	    $ctbool->mklabel([qw(-nc -rep -rec), $lbtype], $dbase)->system;
	}
	# Possibly move the label back to the right versions
	$ctbool->mklabel([qw(-nc -rep), $lbtype], @{$self->{ST_LBL}})->system
	                                                   if $self->{ST_LBL};
	# Last, label the ancestors of the destination back to the vob tag.
	my($dad, @ancestors);
	my $min = length($self->normalize($dvob));
	for ($dad = dirname($dbase);
			         length($dad) >= $min; $dad = dirname($dad)) {
	    push(@ancestors, $dad);
	}
	$ctq->mklabel([qw(-rep -nc), $lbtype], @ancestors)->system
								if @ancestors;
    }
    $self->clone_ct->lock("lbtype:$lbtype\@$dbase")->system if $locked;
}

sub get_addhash {
    my $self = shift;
    if ($self->{ST_ADD}) {
	return
	    map { $self->{ST_ADD}->{$_}->{src}, $self->{ST_ADD}->{$_}->{dst} }
		keys %{$self->{ST_ADD}};
    } else {
	return ();
    }
}

sub get_modhash {
    my $self = shift;
    if ($self->{ST_MOD}) {
	return
	    map { $self->{ST_MOD}->{$_}->{src}, $self->{ST_MOD}->{$_}->{dst} }
		keys %{$self->{ST_MOD}};
    } else {
	return ();
    }
}

sub get_sublist {
    my $self = shift;
    if ($self->{ST_SUB}) {
	return sort keys %{$self->{ST_SUB}->{exfiles}};
    } else {
	return ();
    }
}

sub checkin {
    my $self = shift;
    my $mbase = $self->_mkbase;
    my $dad = dirname($mbase);
    my @ptime = qw(-pti) unless $self->ctime;
    my @cmnt = @{$self->comment};
    my $ct = $self->clone_ct({autochomp=>0});
    # If special eltypes are registered, chtype them here.
    if (my %emap = $self->eltypemap) {
	for my $re (keys %emap) {
	    my @chtypes = grep {/$re/} map {$self->{ST_ADD}->{$_}->{dst}}
				       keys %{$self->{ST_ADD}};
	    next unless @chtypes;
	    $ct->chtype([@cmnt, '-f', $emap{$re}], @chtypes)->system;
	}
    }
    # Do one-by-one ci's with -from (to preserve CR's) unless
    # otherwise requested.
    if (! $self->no_cr) {
	for (keys %{$self->{ST_CI_FROM}}) {
	    my $src = $self->{ST_CI_FROM}->{$_}->{src};
	    my $dst = $self->{ST_CI_FROM}->{$_}->{dst};
	    $ct->ci([@ptime, @cmnt, qw(-ide -rm -from), $src], $dst)->system;
	}
	delete @{$self->{ST_MOD}}{keys %{$self->{ST_CI_FROM}}};
    }
    # Check-in first the files modified under the recorded names,