view release on metacpan or  search on metacpan

SyncTree.pm  view on Meta::CPAN

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,
    # in case of hardlinks, since checking the other link first
    # in a pair would fail.
    my @mods;
    push @mods, $self->{ST_MOD}->{$_}->{dst} for
       grep {!ccsymlink($self->{ST_MOD}->{$_}->{dst})} keys %{$self->{ST_MOD}};
    $ct->ci([@cmnt, '-ide', @ptime], sort @mods)->system if @mods;
    # Check in anything not handled above.
    my %checkedout = map {$_ => 1} $self->_lsco;
    my @todo = grep {m%^\Q$mbase%} keys %checkedout;
    @todo = grep {!exists($self->{ST_PRE}->{$_})} @todo if $self->ignore_co;
    unshift(@todo, $dad) if $checkedout{$dad};
    # Sort reverse in case the checked in versions are not selected by the view
    $ct->argv('ci', [@cmnt, '-ide', @ptime], sort {$b cmp $a} @todo)->system
                                                                      if @todo;
    # Fix the protections of the target files if requested. Unix files
    # get careful consideration of bitmasks etc; Windows files just get
    # promoted to a+x if their extension looks executable.
    if ($self->protect) {
	if (MSWIN) {
	    my @exes;
	    for (keys %{$self->{ST_ADD}}) {
		next unless m%\.(bat|cmd|exe|dll|com|cgi|.?sh|pl)$%i;
		push(@exes, $self->{ST_ADD}->{$_}->{dst});
	    }
	    $ct->argv('protect', [qw(-chmod a+x)], @exes)->system if @exes;
	} else {
	    my %perms;
	    for (keys %{$self->{ST_ADD}}) {
		my $src = $self->{ST_ADD}->{$_}->{src};
		my $dst = $self->{ST_ADD}->{$_}->{dst};
		my $src_mode = (stat $src)[2];
		my $dst_mode = (stat $dst)[2];
		# 07551 represents the only bits that matter to clearcase
		if (($src_mode & 07551) ne ($dst_mode & 07551) &&
			$src !~ m%\.(?:p|html?|gif|mak|rc|ini|java|
				    c|cpp|cxx|h|bmp|ico)$|akefile%x) {
		    my $sym = sprintf("%o", ($src_mode & 07775) | 0444);
		    push(@${$perms{$sym}}, $dst);
		}
	    }
	    for (keys %{$self->{ST_MOD}}) {
		my $src = $self->{ST_MOD}->{$_}->{src};
		my $dst = $self->{ST_MOD}->{$_}->{dst};
		my $src_mode = (stat $src)[2];
		my $dst_mode = (stat $dst)[2];
		# 07551 represents the only bits that matter to clearcase
		if (($src_mode & 07551) ne ($dst_mode & 07551) &&
			$src !~ m%\.(?:p|html?|gif|mak|rc|ini|java|
				    c|cpp|cxx|h|bmp|ico)$|akefile%x) {
		    my $sym = sprintf("%o", ($src_mode & 07775) | 0444);
		    push(@${$perms{$sym}}, $dst);
		}
	    }
	    for (keys %perms) {
		$ct->argv('protect', ['-chmod', $_], @${$perms{$_}})->system;
	    }
	}
    }
}

sub cleanup {
    my $self = shift;
    my $mbase = $self->_mkbase;
    my $dad = dirname($mbase);
    my $ct = $self->clone_ct({autofail=>0});
    my @vp = $self->_lsprivate(1);
    for (sort {$b cmp $a} @vp) {
	if (-d $_) {
	    rmdir $_ || warn "$0: Error: unable to remove $_\n";
	} else {
	    unlink $_ || warn "$0: Error: unable to remove $_\n";
	}
    }
    my %checkedout = map {$_ => 1} $self->_lsco;
    my @todo = grep {m%^\Q$mbase%} keys %checkedout;
    @todo = grep {!exists($self->{ST_PRE}->{$_})} @todo
				    if $self->ignore_co || $self->overwrite_co;
    unshift(@todo, $dad) if $checkedout{$dad};
    if ($self->{branchoffroot}) {
	for (sort {$b cmp $a} @todo) {
	    my $b = $ct->ls([qw(-s -d)], $_)->qx;
	    $ct->unco([qw(-rm)], $_)->system;
	    if ($b =~ s%^(.*)[\\/]CHECKEDOUT$%$1%) {
		opendir BR, $b or next;
		my @f = grep !/^(\.\.?|0|LATEST)$/, readdir BR;
		closedir BR;
		$ct->rmbranch([qw(-f)], $b)->system unless @f;
	    }
	}
    } else {
	$ct->unco([qw(-rm)], sort {$b cmp $a} @todo)->system if @todo;
    }
}

# Undo current work and exit. May be called from an exception handler.
sub fail {
    my $self = shift;
    my $rc = shift;
    $self->ct->autofail(0);	# avoid exception-handler loop
    $self->cleanup;
    exit(defined($rc) ? $rc : 2);
}

sub failm {
    my ($self, $msg, $rc) = @_;
    warn "$0: Error: $msg\n";
    $self->fail($rc);
}

sub version {
    my $self = shift;
    return $ClearCase::SyncTree::VERSION;
}

# Here 'ecs' means Exists Case Sensitive. We don't generally