view release on metacpan or  search on metacpan

lib/App/FuguBench/Worktree.pm  view on Meta::CPAN

# _copy_env_tree($app, $src, $dst, $nested):
#	Copy each regular .env file of one source tree, at any depth,
#	into the clone (WT-CLONE-3). The files are gitignored, so the
#	clone above holds none of them. The walk skips .git and a
#	nested worktree directory, and it copies no symbolic link: a
#	.env link is content of the repository, and it stays there.
sub _copy_env_tree ( $app, $src, $dst, $nested )
{
	my $ok = 1;
	File::Find::find( {
			no_chdir => 1,
			wanted   => sub {
				my $name = $File::Find::name;
				my $base = basename($name);
				my $skip = $base eq '.git'
				    || ( $name ne $src && $name =~ $nested );
				if ($skip) {
					$File::Find::prune = 1;
					return;
				}
				return unless $base eq '.env';
				return if -l $name || !-f $name;

				# A gitignored parent directory is absent
				# in the clone, so the copy makes it.
				my $rel    = substr $name, length($src) + 1;
				my $parent = dirname("$dst/$rel");
				File::Path::make_path($parent)
				    unless -d $parent;
				$ok = 0
				    unless _copy_file( $app, $name,
					"$dst/$rel" );

				return;
			},
		},
		$src
	);

	return $ok;
}

# _copy_file($app, $src, $dst):
#	Copy one file with the mode of the source. The method returns
#	0 after a failure.
sub _copy_file ( $app, $src, $dst )
{
	my $log = $app->cli->log;

	# A project can leave a symbolic link at the destination, and
	# the copy must not write through it. A regular file that
	# exists stays, so a second run keeps a local change
	# (WT-CLONE-4).
	unlink $dst if -l $dst;
	if ( -e $dst ) {
		$log->notice( 'already exists, skipped: %s', $dst );
		return 1;
	}

	# A .env file holds credentials, so the copy takes the mode of
	# the source and not the default of the umask. The stat runs
	# before the copy: a stat after it can follow a parallel
	# removal of the source, and the chmod then gives the copy the
	# mode 0.
	my @stat = stat $src;
	unless ( File::Copy::copy( $src, $dst ) ) {
		$log->error( 'cannot copy %s -> %s: %s', $src, $dst, $! );
		return 0;
	}
	if ( @stat && chmod( $stat[2] & 07777, $dst ) != 1 ) {
		$log->error( 'cannot set the mode of %s: %s', $dst, $! );

		# A copy of a credential file at the mode of the umask
		# is wider than the source, so it must not stay.
		unlink $dst
		    or $log->error( 'cannot remove %s: %s', $dst, $! );

		return 0;
	}
	$log->notice( 'copied %s -> %s', $src, $dst );

	return 1;
}

# _delete_branch($app, $root, $branch):
#	Delete one branch, and report nothing about a branch that is
#	gone. The method never deletes main, and never the branch that
#	the main checkout has checked out (WT-REMOVE-5). A parallel
#	remove that deletes the branch first is no error. The method
#	returns 0 when the branch stays.
sub _delete_branch ( $app, $root, $branch )
{
	return 1
	    unless defined $branch && length $branch && $branch ne 'main';

	my $head = _capture( $app, 'git', '-C', $root, 'symbolic-ref',
		'--quiet', '--short', 'HEAD' );
	return 1 if defined $head && $branch eq $head;
	return 1 unless _branch_exists( $app, $root, $branch );

	return 1
	    if defined $app->command(
		[ 'git', '-C', $root, 'branch', '-D', $branch ] );
	return 1 unless _branch_exists( $app, $root, $branch );

	$app->cli->log->error( 'cannot delete the branch %s', $branch );

	return 0;
}

# _branch_exists($app, $repo, $branch):
#	True when the repository holds the branch.
sub _branch_exists ( $app, $repo, $branch )
{
	return defined $app->command( [
		'git',      '-C',
		$repo,      'show-ref',
		'--verify', '--quiet',
		"refs/heads/$branch"
	] );