view release on metacpan or  search on metacpan

t/19-push.t  view on Meta::CPAN

ok ! -e $local_path;

unless ($ENV{NETWORK_TESTING} or $ENV{RELEASE_TESTING}) {
	diag('remote push tests require network');
	done_testing;
	exit;
}

if ($^O eq 'MSWin32') {
	diag("Windows doesn't have a SSH server, skipping SSH push tests");
	done_testing;
	exit;
}

my %features = Git::Raw -> features;
if ($features{'ssh'} == 0) {
	diag("SSH support not available, skipping SSH push tests");
	done_testing;
	exit;
}

if (!$ENV{SSH_TESTING}) {
	diag("SSH testing not available, skipping SSH clone tests");
	done_testing;
	exit;
}

my $remote_path = rel2abs(catfile('t', 'test_repo'));
my $remote_port = $ENV{AUTHOR_TESTING} ? 22 : 2222;
my $remote_url = "ssh://$ENV{USER}\@localhost:$remote_port$remote_path";
$path = rel2abs(catfile('t', 'test_repo_ssh'));

my $challenge = sub {
	my ($name, $instruction, @prompts) = @_;

	is scalar(@prompts), 1;
	my $prompt = shift @prompts;
	like $prompt->{text}, qr/Password/;
	is $prompt->{echo}, 0;
	return ('blah');
};

my $tried_interactive = 0;
my $credentials = sub {
	my ($url, $user, $types) = @_;

	is ref($types), 'ARRAY';
	is scalar(grep { $_ eq 'ssh_key' } @$types), 1;
	is scalar(grep { $_ eq 'ssh_custom' } @$types), 1;
	is scalar(grep { $_ eq 'ssh_interactive' } @$types), 1;

	if (!$tried_interactive) {
		$tried_interactive = 1;
		return Git::Raw::Cred -> sshinteractive($user, $challenge);
	}

	my $ssh_dir = File::Spec -> catfile($ENV{HOME}, '.ssh');
	ok -e $ssh_dir;

	my $public_key = File::Spec -> catfile($ssh_dir, 'id_rsa.pub');
	my $private_key = File::Spec -> catfile($ssh_dir, 'id_rsa');
	ok -f $public_key;
	ok -f $private_key;

	return Git::Raw::Cred -> sshkey($user, $public_key, $private_key);
};

$repo = Git::Raw::Repository -> clone($remote_url, $path, {}, {
	'callbacks' => {
		'credentials' => $credentials
	}
});

ok !$repo -> is_empty;
@remotes = $repo -> remotes;

my $config = $repo -> config;
$config -> str('user.name', 'some user');
$config -> str('user.email', 'someuser@somewhere.com');

my $branch = Git::Raw::Branch -> create($repo, "ssh_branch", $repo -> head -> target);
isa_ok $branch, 'Git::Raw::Branch';

$repo -> checkout($repo -> head($branch), {
	'checkout_strategy' => {
		'safe' => 1
	}
});

my $file  = $repo -> workdir . 'file_on_ssh_branch';
write_file($file, 'this is a test');

my $index = $repo -> index;
$index -> add('file_on_ssh_branch');
$index -> write;

my $me = Git::Raw::Signature -> default($repo);
my $commit = $repo -> commit("commit on file_on_ssh_branch\n", $me, $me, [$branch -> target],
	$index -> write_tree);

is scalar(@remotes), 1;
$remote = shift @remotes;

my ($credentials_fired, $sideband_fired, $update_tips_fired) = (0, 0, 0);
my ($pack_progress_fired, $transfer_progress_fired, $status_fired) = (0, 0, 0);
my ($negotation_fired, $transport_fired) = (0, 0);

my $callbacks = {
	'credentials' => sub {
		$credentials_fired = 1;
		return &{$credentials}(@_);
	},
	'sideband_progress' => sub {
		my ($msg) = @_;

		diag("Remote message (sideband): $msg");
		is $msg, "This is from the pre-receive hook! (Disallowing it)";
		$sideband_fired = 1;
	},
	'pack_progress' => sub {
		my ($stage, $current, $total) = @_;

		$pack_progress_fired = 1;
	},
	'push_transfer_progress' => sub {